From addb648937b5d98f5094fc83f26e0011a9ecc717 Mon Sep 17 00:00:00 2001 From: Fendor Date: Mon, 20 Jun 2022 13:52:15 +0200 Subject: [PATCH 1/6] Fix parameter switch-up --- ghcide/test/exe/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From fed7ad7efb95eecf12ebda20b00ca8a108289971 Mon Sep 17 00:00:00 2001 From: Jana Chadt Date: Fri, 6 Aug 2021 12:12:00 +0200 Subject: [PATCH 2/6] Generalise file extension handling for plugins NotificationHandler now distinguishes between different file extensions RequestHandler distinguishes between different file extensions --- ghcide/src/Development/IDE/Plugin/HLS.hs | 87 +++++---- haskell-language-server.cabal | 3 +- hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Types.hs | 167 ++++++++++++++++-- .../default/src/Ide/Plugin/ExampleCabal.hs | 2 + 5 files changed, 209 insertions(+), 51 deletions(-) create mode 100644 plugins/default/src/Ide/Plugin/ExampleCabal.hs diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 7c8c7cec68..bb28a402c9 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 id <> + mkPlugin (extensibleNotificationPlugins recorder) id <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where @@ -153,55 +153,80 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config +extensiblePlugins :: [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensiblePlugins xs = mempty { P.pluginHandlers = handlers } where + getPluginDescriptor pid = lookup pid xs IdeHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers - bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers + bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map (\(PluginHandler f) -> IdeHandler [(pid,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' - 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 - 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 - 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 + let pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs' + cleanPluginInfo <- collectPluginDescriptors pluginInfo [] + case cleanPluginInfo of + Left err -> pure $ Left err + Right pluginInfos -> do + let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled m params desc config) (zip pluginInfos 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 + 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 + 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 + +collectPluginDescriptors :: [(PluginId, Maybe (PluginDescriptor c))] -> [(PluginId, PluginDescriptor c)] -> LSP.LspM Config (Either ResponseError [(PluginId, PluginDescriptor c)]) +collectPluginDescriptors ((pid, Nothing):_) _ = pure $ Left $ ResponseError InvalidRequest + ("No plugindescriptor found for " <> pidT <> ", available: ") + Nothing + where + PluginId pidT = pid +collectPluginDescriptors ((pid, Just desc):xs) ys = collectPluginDescriptors xs (ys ++ [(pid, desc)]) +collectPluginDescriptors [] ys = pure $ Right ys + -- --------------------------------------------------------------------- -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 + getPluginDescriptor pid = lookup pid xs IdeNotificationHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers - bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers + bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,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' - case nonEmpty fs of - Nothing -> do - 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 + let pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs' + cleanPluginInfo <- collectPluginDescriptors pluginInfo [] + case cleanPluginInfo of + Left _ -> pure () + Right pluginInfos -> do + let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled2 m params desc config) (zip pluginInfos fs') + case nonEmpty fs of + Nothing -> do + 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 -- --------------------------------------------------------------------- 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..84bc9006c3 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -69,6 +69,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,7 +109,7 @@ instance Show (IdeCommand st) where show _ = "" -- --------------------------------------------------------------------- -data PluginDescriptor ideState = +data PluginDescriptor (ideState :: *) = PluginDescriptor { pluginId :: !PluginId , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand ideState] @@ -117,6 +118,11 @@ 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 '.'. } -- | An existential wrapper of 'Properties' @@ -162,7 +168,7 @@ defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyPrope class HasTracing (MessageParams m) => PluginMethod m where -- | Parse the configuration to check if this plugin is enabled - pluginEnabled :: SMethod m -> PluginId -> Config -> Bool + pluginEnabled :: SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool -- | How to combine responses from different plugins combineResponses @@ -177,11 +183,13 @@ class HasTracing (MessageParams m) => PluginMethod m where combineResponses _method _config _caps _params = sconcat instance PluginMethod TextDocumentCodeAction where - pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn + pluginEnabled _ msgParams pluginDesc config = + pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri 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) @@ -224,12 +232,63 @@ instance PluginMethod TextDocumentReferences where instance PluginMethod WorkspaceSymbol where pluginEnabled _ _ _ = True +-- | 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 + +instance PluginMethod TextDocumentDefinition where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + combineResponses _ _ _ _ (x :| _) = x + +instance PluginMethod TextDocumentTypeDefinition where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + combineResponses _ _ _ _ (x :| _) = x + +instance PluginMethod TextDocumentDocumentHighlight where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod TextDocumentReferences where + pluginEnabled _ msgParams pluginDesc _ = + pluginResponsible uri pluginDesc + where + uri = msgParams ^. J.textDocument . J.uri + +instance PluginMethod WorkspaceSymbol where + pluginEnabled _ _ _ _ = True + instance PluginMethod TextDocumentCodeLens where - pluginEnabled _ = pluginEnabledConfig plcCodeLensOn + pluginEnabled _ msgParams pluginDesc config = + pluginResponsible uri pluginDesc + && pluginEnabledConfig plcCodeLensOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri + instance PluginMethod TextDocumentRename where - pluginEnabled _ = pluginEnabledConfig plcRenameOn + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcRenameOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri instance PluginMethod TextDocumentHover where - pluginEnabled _ = pluginEnabledConfig plcHoverOn + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcHoverOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri combineResponses _ _ _ _ (catMaybes . toList -> hs) = h where r = listToMaybe $ mapMaybe (^. range) hs @@ -238,7 +297,10 @@ instance PluginMethod TextDocumentHover where hh -> Just $ Hover hh r instance PluginMethod TextDocumentDocumentSymbol where - pluginEnabled _ = pluginEnabledConfig plcSymbolsOn + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcSymbolsOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res where uri' = params ^. textDocument . uri @@ -260,7 +322,10 @@ instance PluginMethod TextDocumentDocumentSymbol where in [si] <> children' instance PluginMethod TextDocumentCompletion where - pluginEnabled _ = pluginEnabledConfig plcCompletionOn + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcCompletionOn (pluginId pluginDesc) config + where + uri = msgParams ^. J.textDocument . J.uri combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where limit = maxCompletions conf @@ -289,32 +354,82 @@ instance PluginMethod TextDocumentCompletion where consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) instance PluginMethod TextDocumentFormatting where - pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid - combineResponses _ _ _ _ (x :| _) = x + pluginEnabled STextDocumentFormatting msgParams pluginDesc conf = + pluginResponsible uri pluginDesc && PluginId (formattingProvider conf) == pid + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc + combineResponses _ _ _ _ x = sconcat x + instance PluginMethod TextDocumentRangeFormatting where - pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && PluginId (formattingProvider conf) == pid + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc combineResponses _ _ _ _ (x :| _) = x instance PluginMethod TextDocumentPrepareCallHierarchy where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcCallHierarchyOn pid conf + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc instance PluginMethod TextDocumentSelectionRange where - pluginEnabled _ = pluginEnabledConfig plcSelectionRangeOn + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcSelectionRangeOn pid conf + where + pid = pluginId pluginDesc combineResponses _ _ _ _ (x :| _) = x instance PluginMethod CallHierarchyIncomingCalls where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf + where + pid = pluginId pluginDesc instance PluginMethod CallHierarchyOutgoingCalls where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf + where + pid = pluginId pluginDesc instance PluginMethod CustomMethod where - pluginEnabled _ _ _ = True + pluginEnabled _ _ _ _ = True combineResponses _ _ _ _ (x :| _) = x -- --------------------------------------------------------------------- +class HasTracing (MessageParams m) => PluginNotificationMethod (m :: Method FromClient Notification) where + pluginEnabled2 :: SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool + + default pluginEnabled2 :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri) + => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool + pluginEnabled2 _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf (pluginId desc)) + where + uri = params ^. J.textDocument . J.uri + +instance PluginNotificationMethod TextDocumentDidOpen where + +instance PluginNotificationMethod TextDocumentDidChange where + +instance PluginNotificationMethod TextDocumentDidSave where + +instance PluginNotificationMethod TextDocumentDidClose where + +instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where + pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where + pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginNotificationMethod WorkspaceDidChangeConfiguration where + pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginNotificationMethod Initialized where + pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +-- --------------------------------------------------------------------- + -- | Methods which have a PluginMethod instance data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m) instance GEq IdeMethod where @@ -323,7 +438,7 @@ 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 @@ -372,7 +487,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 @@ -392,6 +507,20 @@ defaultPluginDescriptor plId = mempty mempty Nothing + [".hs", ".lhs", ".hs-boot"] + +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..d09d4e6547 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/ExampleCabal.hs @@ -0,0 +1,2 @@ +module Ide.Plugin.ExampleCabal where + From 53b903e32c82ca7588576efa32b0f0c85c96221a Mon Sep 17 00:00:00 2001 From: Jana Chadt Date: Mon, 13 Jun 2022 13:21:04 +0200 Subject: [PATCH 3/6] Introduce PluginMethod Typeclass hierarchy The hierarchy looks as follows: PluginMethod (pluginEnabled) | ----------------------------------- | | PluginRequestMethod PluginNotificationMethod --- ghcide/src/Development/IDE/Plugin/HLS.hs | 2 +- hls-plugin-api/src/Ide/Types.hs | 205 +++++++++++++++-------- 2 files changed, 135 insertions(+), 72 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index bb28a402c9..2ae5fb7362 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -218,7 +218,7 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers case cleanPluginInfo of Left _ -> pure () Right pluginInfos -> do - let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled2 m params desc config) (zip pluginInfos fs') + let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled m params desc config) (zip pluginInfos fs') case nonEmpty fs of Nothing -> do logWith recorder Info LogNoEnabledPlugins diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 84bc9006c3..a742ba4f32 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 @@ -165,11 +166,25 @@ 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 - pluginEnabled :: SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool + pluginEnabled + :: SMethod m + -> 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 + -> Config + -> Bool + + 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 +class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient Request) where -- | How to combine responses from different plugins combineResponses :: SMethod m @@ -182,11 +197,14 @@ 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 + +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 @@ -243,52 +261,121 @@ pluginResponsible uri pluginDesc where mfp = uriToFilePath uri -instance PluginMethod TextDocumentDefinition where +instance PluginMethod Request TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where uri = msgParams ^. J.textDocument . J.uri - combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentTypeDefinition where +instance PluginMethod Request TextDocumentTypeDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where uri = msgParams ^. J.textDocument . J.uri - combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentDocumentHighlight where +instance PluginMethod Request TextDocumentDocumentHighlight where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where uri = msgParams ^. J.textDocument . J.uri -instance PluginMethod TextDocumentReferences where +instance PluginMethod Request TextDocumentReferences where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where uri = msgParams ^. J.textDocument . J.uri -instance PluginMethod WorkspaceSymbol where +instance PluginMethod Request WorkspaceSymbol where pluginEnabled _ _ _ _ = True -instance PluginMethod TextDocumentCodeLens where +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 TextDocumentRename where +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 TextDocumentHover where +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 + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf + where + pid = pluginId pluginDesc + +instance PluginMethod Request CallHierarchyOutgoingCalls where + 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 @@ -296,11 +383,7 @@ instance PluginMethod TextDocumentHover where HoverContentsMS (List []) -> Nothing hh -> Just $ Hover hh r -instance PluginMethod TextDocumentDocumentSymbol where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcSymbolsOn (pluginId pluginDesc) config - where - uri = msgParams ^. J.textDocument . J.uri +instance PluginRequestMethod TextDocumentDocumentSymbol where combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res where uri' = params ^. textDocument . uri @@ -321,11 +404,7 @@ instance PluginMethod TextDocumentDocumentSymbol where si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent in [si] <> children' -instance PluginMethod TextDocumentCompletion where - pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCompletionOn (pluginId pluginDesc) config - where - uri = msgParams ^. J.textDocument . J.uri +instance PluginRequestMethod TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where limit = maxCompletions conf @@ -353,60 +432,36 @@ instance PluginMethod TextDocumentCompletion where consumeCompletionResponse n (InL (List xx)) = consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) -instance PluginMethod TextDocumentFormatting where - pluginEnabled STextDocumentFormatting msgParams pluginDesc conf = - pluginResponsible uri pluginDesc && PluginId (formattingProvider conf) == pid - where - uri = msgParams ^. J.textDocument . J.uri - pid = pluginId pluginDesc - combineResponses _ _ _ _ x = sconcat x - +instance PluginRequestMethod TextDocumentFormatting where + combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentRangeFormatting where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && PluginId (formattingProvider conf) == pid - where - uri = msgParams ^. J.textDocument . J.uri - pid = pluginId pluginDesc +instance PluginRequestMethod TextDocumentRangeFormatting where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod TextDocumentPrepareCallHierarchy where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCallHierarchyOn pid conf - where - uri = msgParams ^. J.textDocument . J.uri - pid = pluginId pluginDesc +instance PluginRequestMethod TextDocumentPrepareCallHierarchy where -instance PluginMethod TextDocumentSelectionRange where - pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcSelectionRangeOn pid conf - where - pid = pluginId pluginDesc +instance PluginRequestMethod TextDocumentSelectionRange where combineResponses _ _ _ _ (x :| _) = x -instance PluginMethod CallHierarchyIncomingCalls where - pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf - where - pid = pluginId pluginDesc +instance PluginRequestMethod CallHierarchyIncomingCalls where -instance PluginMethod CallHierarchyOutgoingCalls where - pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf - where - pid = pluginId pluginDesc +instance PluginRequestMethod CallHierarchyOutgoingCalls where -instance PluginMethod CustomMethod where - pluginEnabled _ _ _ _ = True +instance PluginRequestMethod CustomMethod where combineResponses _ _ _ _ (x :| _) = x - -- --------------------------------------------------------------------- -class HasTracing (MessageParams m) => PluginNotificationMethod (m :: Method FromClient Notification) where - pluginEnabled2 :: SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool +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 - default pluginEnabled2 :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri) - => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool - pluginEnabled2 _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf (pluginId desc)) - where - uri = params ^. J.textDocument . J.uri instance PluginNotificationMethod TextDocumentDidOpen where @@ -416,22 +471,30 @@ instance PluginNotificationMethod TextDocumentDidSave where instance PluginNotificationMethod TextDocumentDidClose where +instance PluginMethod Notification WorkspaceDidChangeWatchedFiles where + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginMethod Notification WorkspaceDidChangeWorkspaceFolders where + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginMethod Notification WorkspaceDidChangeConfiguration where + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + +instance PluginMethod Notification Initialized where + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where - pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where - pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) instance PluginNotificationMethod WorkspaceDidChangeConfiguration where - pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) instance PluginNotificationMethod Initialized where - pluginEnabled2 _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) -- --------------------------------------------------------------------- -- | 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 @@ -477,7 +540,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 From c8eb96b7cba2edf4becac863e49ea54ba2cb849a Mon Sep 17 00:00:00 2001 From: Fendor Date: Mon, 20 Jun 2022 19:49:08 +0200 Subject: [PATCH 4/6] Add example plugin --- exe/Plugins.hs | 2 + .../default/src/Ide/Plugin/ExampleCabal.hs | 73 +++++++++++++++++++ 2 files changed, 75 insertions(+) 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/plugins/default/src/Ide/Plugin/ExampleCabal.hs b/plugins/default/src/Ide/Plugin/ExampleCabal.hs index d09d4e6547..74f7982393 100644 --- a/plugins/default/src/Ide/Plugin/ExampleCabal.hs +++ b/plugins/default/src/Ide/Plugin/ExampleCabal.hs @@ -1,2 +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 From e7e60bcb04f83aaefad2ce2a294431447ff1fdc4 Mon Sep 17 00:00:00 2001 From: Fendor Date: Mon, 20 Jun 2022 18:14:58 +0200 Subject: [PATCH 5/6] Improve documentation for plugins --- hls-plugin-api/src/Ide/Types.hs | 149 +++++++++++++++++++++----------- 1 file changed, 100 insertions(+), 49 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index a742ba4f32..7d60fd281d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -112,6 +112,7 @@ instance Show (IdeCommand st) where show _ = "" data PluginDescriptor (ideState :: *) = PluginDescriptor { pluginId :: !PluginId + -- ^ Unique identifier of the plugin. , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand ideState] , pluginHandlers :: PluginHandlers ideState @@ -126,11 +127,23 @@ data PluginDescriptor (ideState :: *) = -- 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": { @@ -143,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'. @@ -168,15 +182,43 @@ defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyPrope -- Only methods for which we know how to combine responses can be instances of 'PluginMethod' class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Method FromClient k) where - -- | Parse the configuration to check if this plugin is enabled + -- | 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 @@ -184,8 +226,21 @@ class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Metho 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 + -- | 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 @@ -197,7 +252,6 @@ class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient Requ => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m combineResponses _method _config _caps _params = sconcat - instance PluginMethod Request TextDocumentCodeAction where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (pluginId pluginDesc) config @@ -231,36 +285,6 @@ instance PluginRequestMethod 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 TextDocumentTypeDefinition where - pluginEnabled _ _ _ = True - combineResponses _ _ _ _ (x :| _) = x - -instance PluginMethod TextDocumentDocumentHighlight where - pluginEnabled _ _ _ = True - combineResponses _ _ _ _ (x :| _) = x - -instance PluginMethod TextDocumentReferences where - pluginEnabled _ _ _ = True - combineResponses _ _ _ _ (x :| _) = x - -instance PluginMethod WorkspaceSymbol where - pluginEnabled _ _ _ = True - --- | 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 - instance PluginMethod Request TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc @@ -286,34 +310,34 @@ instance PluginMethod Request TextDocumentReferences 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 + 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 + 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 + 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 + 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 + pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCompletionOn (pluginId pluginDesc) config where uri = msgParams ^. J.textDocument . J.uri @@ -340,17 +364,20 @@ instance PluginMethod Request TextDocumentPrepareCallHierarchy where pid = pluginId pluginDesc instance PluginMethod Request TextDocumentSelectionRange where - pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc && pluginEnabledConfig plcSelectionRangeOn pid conf + 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 @@ -449,8 +476,13 @@ instance PluginRequestMethod CallHierarchyOutgoingCalls where 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 @@ -462,27 +494,31 @@ instance PluginMethod Notification TextDocumentDidSave where instance PluginMethod Notification TextDocumentDidClose where - -instance PluginNotificationMethod TextDocumentDidOpen where - -instance PluginNotificationMethod TextDocumentDidChange where - -instance PluginNotificationMethod TextDocumentDidSave where - -instance PluginNotificationMethod 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 @@ -559,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 @@ -572,6 +617,12 @@ defaultPluginDescriptor plId = 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 From dd56166a9ced57ee50d880d97c07c81553e89e8f Mon Sep 17 00:00:00 2001 From: Fendor Date: Wed, 22 Jun 2022 13:48:48 +0200 Subject: [PATCH 6/6] Simplify Plugin Handling code --- ghcide/src/Development/IDE/Plugin/HLS.hs | 89 ++++++++++-------------- 1 file changed, 38 insertions(+), 51 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 2ae5fb7362..1959dd8dcd 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -58,7 +58,7 @@ asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin C asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> - mkPlugin extensiblePlugins id <> + mkPlugin (extensiblePlugins recorder) id <> mkPlugin (extensibleNotificationPlugins recorder) id <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where @@ -153,14 +153,13 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginDescriptor 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 - getPluginDescriptor pid = lookup pid xs IdeHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map - (\(PluginHandler f) -> IdeHandler [(pid,f pid)]) + (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)]) hs where PluginHandlers hs = HLS.pluginHandlers pluginDesc @@ -168,65 +167,52 @@ extensiblePlugins xs = mempty { P.pluginHandlers = handlers } (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' pure $ requestHandler m $ \ide params -> do config <- Ide.PluginUtils.getClientConfig - let pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs' - cleanPluginInfo <- collectPluginDescriptors pluginInfo [] - case cleanPluginInfo of - Left err -> pure $ Left err - Right pluginInfos -> do - let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled m params desc config) (zip pluginInfos 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 - 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 - 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 - -collectPluginDescriptors :: [(PluginId, Maybe (PluginDescriptor c))] -> [(PluginId, PluginDescriptor c)] -> LSP.LspM Config (Either ResponseError [(PluginId, PluginDescriptor c)]) -collectPluginDescriptors ((pid, Nothing):_) _ = pure $ Left $ ResponseError InvalidRequest - ("No plugindescriptor found for " <> pidT <> ", available: ") - Nothing - where - PluginId pidT = pid -collectPluginDescriptors ((pid, Just desc):xs) ys = collectPluginDescriptors xs (ys ++ [(pid, desc)]) -collectPluginDescriptors [] ys = pure $ Right ys + -- 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 $ 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) + 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, PluginDescriptor IdeState)] -> Plugin Config extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers } where - getPluginDescriptor pid = lookup pid xs IdeNotificationHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map - (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)]) + (\(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 pluginInfo = map (\(pid,_) -> (pid, getPluginDescriptor pid)) fs' - cleanPluginInfo <- collectPluginDescriptors pluginInfo [] - case cleanPluginInfo of - Left _ -> pure () - Right pluginInfos -> do - let fs = map snd $ filter (\((_, desc), _) -> pluginEnabled m params desc config) (zip pluginInfos fs') - case nonEmpty fs of - Nothing -> do - 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 + -- 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 () + 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 -- --------------------------------------------------------------------- @@ -235,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)) @@ -248,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