Skip to content

Commit

Permalink
Simplify Plugin Handling code
Browse files Browse the repository at this point in the history
  • Loading branch information
Fendor committed Jun 22, 2022
1 parent e7e60bc commit dd56166
Showing 1 changed file with 38 additions and 51 deletions.
89 changes: 38 additions & 51 deletions ghcide/src/Development/IDE/Plugin/HLS.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -153,80 +153,66 @@ 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
handlers = mconcat $ do
(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

-- ---------------------------------------------------------------------

Expand All @@ -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))
Expand All @@ -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
Expand Down

0 comments on commit dd56166

Please sign in to comment.