From cfe643e6271ee0fdbb952a6f5dbcb6c3c234b8a1 Mon Sep 17 00:00:00 2001 From: Fendor Date: Wed, 22 Jun 2022 13:48:48 +0200 Subject: [PATCH] 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 2ae5fb7362f..feb627b33f2 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