Skip to content

Commit 9c5a728

Browse files
wz1000wz1000
committed
handle executeCommand and codeaction compat
1 parent 32dc937 commit 9c5a728

File tree

3 files changed

+152
-35
lines changed

3 files changed

+152
-35
lines changed

‎ghcide/src/Development/IDE/Plugin/HLS.hs

Lines changed: 74 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE DeriveAnyClass #-}
21
{-# LANGUAGE PolyKinds #-}
32
{-# LANGUAGE KindSignatures #-}
43
{-# LANGUAGE DataKinds #-}
@@ -12,6 +11,7 @@ module Development.IDE.Plugin.HLS
1211
import Control.Exception(SomeException)
1312
import Control.Lens ((^.))
1413
import Control.Monad
14+
import Control.Monad.IO.Class
1515
import qualified Data.Aeson as J
1616
import qualified Data.DList as DList
1717
import Data.Either
@@ -22,8 +22,8 @@ import qualified Data.Text as T
2222
import Development.IDE.Core.Shake
2323
import Development.IDE.LSP.Server
2424
import Development.IDE.Plugin
25-
import GHC.Generics
2625
import Ide.Plugin.Config
26+
import Ide.PluginUtils
2727
import Ide.Types as HLS
2828
import qualified Language.LSP.Server as LSP
2929
import qualified Language.LSP.Types as J
@@ -47,23 +47,18 @@ import UnliftIO (MonadUnliftIO)
4747
-- ---------------------------------------------------------------------
4848
--
4949

50-
-- | Map a set of plugins to the underlying ghcide engine. Main point is
51-
-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message
52-
-- category ('Notifaction', 'Request' etc).
50+
-- | Map a set of plugins to the underlying ghcide engine.
5351
asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
5452
asGhcIdePlugin mp =
55-
mkPlugin rulesPlugins (Just . HLS.pluginRules) <>
56-
-- mkPlugin executeCommandPlugins (Just . pluginCommands) <>
57-
mkPlugin extensiblePlugins (Just . HLS.pluginHandlers)
53+
mkPlugin rulesPlugins HLS.pluginRules <>
54+
mkPlugin executeCommandPlugins HLS.pluginCommands <>
55+
mkPlugin extensiblePlugins HLS.pluginHandlers
5856
where
59-
justs (p, Just x) = [(p, x)]
60-
justs (_, Nothing) = []
61-
6257
ls = Map.toList (ipMap mp)
6358

64-
mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config
59+
mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config
6560
mkPlugin maker selector =
66-
case concatMap (\(pid, p) -> justs (pid, selector p)) ls of
61+
case map (\(pid, p) -> (pid, selector p)) ls of
6762
-- If there are no plugins that provide a descriptor, use mempty to
6863
-- create the plugin – otherwise we we end up declaring handlers for
6964
-- capabilities that there are no plugins for
@@ -77,6 +72,70 @@ rulesPlugins rs = Plugin rules mempty
7772
where
7873
rules = foldMap snd rs
7974

75+
-- ---------------------------------------------------------------------
76+
77+
executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
78+
executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs)
79+
80+
executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)
81+
executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
82+
where
83+
pluginMap = Map.fromList ecs
84+
85+
parseCmdId :: T.Text -> Maybe (PluginId, CommandId)
86+
parseCmdId x = case T.splitOn ":" x of
87+
[plugin, command] -> Just (PluginId plugin, CommandId command)
88+
[_, plugin, command] -> Just (PluginId plugin, CommandId command)
89+
_ -> Nothing
90+
91+
-- The parameters to the HLS command are always the first element
92+
93+
execCmd ide (ExecuteCommandParams _ cmdId args) = do
94+
let cmdParams :: J.Value
95+
cmdParams = case args of
96+
Just (J.List (x:_)) -> x
97+
_ -> J.Null
98+
case parseCmdId cmdId of
99+
-- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions
100+
Just ("hls", "fallbackCodeAction") ->
101+
case J.fromJSON cmdParams of
102+
J.Success (FallbackCodeActionParams mEdit mCmd) -> do
103+
104+
-- Send off the workspace request if it has one
105+
forM_ mEdit $ \edit ->
106+
LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())
107+
108+
case mCmd of
109+
-- If we have a command, continue to execute it
110+
Just (J.Command _ innerCmdId innerArgs)
111+
-> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs)
112+
Nothing -> return $ Right J.Null
113+
114+
J.Error _str -> return $ Right J.Null
115+
116+
-- Just an ordinary HIE command
117+
Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams
118+
119+
-- Couldn't parse the command identifier
120+
_ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing
121+
122+
runPluginCommand ide p@(PluginId p') com@(CommandId com') arg =
123+
case Map.lookup p pluginMap of
124+
Nothing -> return
125+
(Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing)
126+
Just xs -> case List.find ((com ==) . commandId) xs of
127+
Nothing -> return $ Left $
128+
ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'
129+
<> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing
130+
Just (PluginCommand _ _ f) -> case J.fromJSON arg of
131+
J.Error err -> return $ Left $
132+
ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'
133+
<> ": " <> T.pack err
134+
<> "\narg = " <> T.pack (show arg)) Nothing
135+
J.Success a -> f ide a
136+
137+
-- ---------------------------------------------------------------------
138+
80139
extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
81140
extensiblePlugins xs = Plugin mempty handlers
82141
where
@@ -88,6 +147,7 @@ extensiblePlugins xs = Plugin mempty handlers
88147
handlers = mconcat $ do
89148
(IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'
90149
pure $ requestHandler m $ \ide params -> do
150+
pid <- liftIO getPid
91151
config <- getClientConfig
92152
let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs'
93153
case nonEmpty fs of
@@ -106,7 +166,7 @@ extensiblePlugins xs = Plugin mempty handlers
106166
Nothing -> pure $ Left $ combineErrors errs
107167
Just xs -> do
108168
caps <- LSP.getClientCapabilities
109-
pure $ Right $ combineResponses m config caps params xs
169+
pure $ Right $ combineResponses m pid config caps params xs
110170

111171
runConcurrently
112172
:: MonadUnliftIO m

‎hls-plugin-api/src/Ide/PluginUtils.hs

Lines changed: 3 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Ide.PluginUtils
1919
fullRange,
2020
mkLspCommand,
2121
mkLspCmdId,
22+
getPid,
2223
allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange)
2324
where
2425

@@ -227,15 +228,9 @@ allLspCmdIds pid commands = concat $ map go commands
227228
go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds
228229

229230
mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command
230-
mkLspCommand plid cn title args' = do
231+
mkLspCommand plid cn title args = do
231232
pid <- getPid
232-
let cmdId = mkLspCmdId pid plid cn
233-
let args = List <$> args'
234-
return $ Command title cmdId args
235-
236-
mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
237-
mkLspCmdId pid (PluginId plid) (CommandId cid)
238-
= pid <> ":" <> plid <> ":" <> cid
233+
pure $ mkLspCommand' pid plid cn title args
239234

240235
-- | Get the operating system process id for the running server
241236
-- instance. This should be the same for the lifetime of the instance,

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 75 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE OverloadedStrings #-}
23
{-# LANGUAGE ScopedTypeVariables #-}
34
{-# LANGUAGE DataKinds #-}
45
{-# LANGUAGE KindSignatures #-}
@@ -10,15 +11,18 @@
1011
{-# LANGUAGE BangPatterns #-}
1112
{-# LANGUAGE TypeOperators #-}
1213
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE DeriveAnyClass #-}
15+
{-# LANGUAGE DeriveGeneric #-}
1316

1417
module Ide.Types
1518
where
1619

1720
import Data.Aeson hiding (defaultOptions)
21+
import GHC.Generics
1822
import qualified Data.Map as Map
1923
import Data.String
2024
import qualified Data.Text as T
21-
import Development.Shake
25+
import Development.Shake hiding (command)
2226
import Ide.Plugin.Config
2327
import Language.LSP.Types
2428
import Language.LSP.VFS
@@ -29,6 +33,7 @@ import Text.Regex.TDFA.Text()
2933
import Data.Dependent.Map (DMap)
3034
import qualified Data.Dependent.Map as DMap
3135
import Data.List.NonEmpty (NonEmpty(..), toList)
36+
import qualified Data.List.NonEmpty as NE
3237
import Data.GADT.Compare
3338
import Data.Maybe
3439
import Data.Semigroup
@@ -69,20 +74,49 @@ class PluginMethod m where
6974
pluginEnabled :: SMethod m -> PluginId -> Config -> Bool
7075

7176
-- | How to combine responses from different plugins
72-
combineResponses :: SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m
73-
74-
default combineResponses :: Semigroup (ResponseResult m) => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m
75-
combineResponses _method _config _caps _params = sconcat
77+
combineResponses
78+
:: SMethod m
79+
-> T.Text -- ^ the process id, to make commands
80+
-> Config -- ^ IDE Configuration
81+
-> ClientCapabilities
82+
-> MessageParams m
83+
-> NonEmpty (ResponseResult m) -> ResponseResult m
84+
85+
default combineResponses :: Semigroup (ResponseResult m)
86+
=> SMethod m -> T.Text -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m
87+
combineResponses _method _pid _config _caps _params = sconcat
7688

7789
instance PluginMethod TextDocumentCodeAction where
7890
pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn
91+
combineResponses _method pid _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ docId range context) resps =
92+
fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps
93+
where
94+
95+
compat :: (Command |? CodeAction) -> (Command |? CodeAction)
96+
compat x@(InL _) = x
97+
compat x@(InR action)
98+
| Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport
99+
= x
100+
| otherwise = InL cmd
101+
where
102+
cmd = mkLspCommand' pid "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)
103+
cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]
104+
105+
wasRequested :: (Command |? CodeAction) -> Bool
106+
wasRequested (InL _) = True
107+
wasRequested (InR ca)
108+
| Nothing <- _only context = True
109+
| Just (List allowed) <- _only context
110+
, Just caKind <- ca ^. kind = caKind `elem` allowed
111+
| otherwise = False
112+
79113
instance PluginMethod TextDocumentCodeLens where
80114
pluginEnabled _ = pluginEnabledConfig plcCodeLensOn
81115
instance PluginMethod TextDocumentRename where
82116
pluginEnabled _ = pluginEnabledConfig plcRenameOn
83117
instance PluginMethod TextDocumentHover where
84118
pluginEnabled _ = pluginEnabledConfig plcHoverOn
85-
combineResponses _ _ _ _ (catMaybes . toList -> hs) = h
119+
combineResponses _ _ _ _ _ (catMaybes . toList -> hs) = h
86120
where
87121
r = listToMaybe $ mapMaybe (^. range) hs
88122
h = case foldMap (^. contents) hs of
@@ -91,7 +125,7 @@ instance PluginMethod TextDocumentHover where
91125

92126
instance PluginMethod TextDocumentDocumentSymbol where
93127
pluginEnabled _ = pluginEnabledConfig plcSymbolsOn
94-
combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res
128+
combineResponses _ _ _ (ClientCapabilities _ tdc _ _) params xs = res
95129
where
96130
uri' = params ^. textDocument . uri
97131
supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)
@@ -113,7 +147,7 @@ instance PluginMethod TextDocumentDocumentSymbol where
113147

114148
instance PluginMethod TextDocumentCompletion where
115149
pluginEnabled _ = pluginEnabledConfig plcCompletionOn
116-
combineResponses _ conf _ _ (toList -> xs) = consumeCompletionResponse limit $ combine xs
150+
combineResponses _ _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs
117151
where
118152
limit = maxCompletions conf
119153
combine :: [List CompletionItem |? CompletionList] -> ((List CompletionItem) |? CompletionList)
@@ -126,12 +160,19 @@ instance PluginMethod TextDocumentCompletion where
126160
go comp acc (InR (CompletionList comp' (List ls)) : rest) =
127161
go (comp && comp') (acc <> DList.fromList ls) rest
128162

163+
-- boolean disambiguators
164+
isCompleteResponse, isIncompleteResponse :: Bool
165+
isIncompleteResponse = True
166+
isCompleteResponse = False
167+
129168
consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) =
130169
case splitAt limit xx of
131-
(_, []) -> it
132-
(xx', _) -> InR (CompletionList False (List xx'))
170+
-- consumed all the items, return the result as is
171+
(_, []) -> (limit - length xx, it)
172+
-- need to crop the response, set the 'isIncomplete' flag
173+
(xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx')))
133174
consumeCompletionResponse n (InL (List xx)) =
134-
consumeCompletionResponse n (InR (CompletionList False (List xx)))
175+
consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))
135176

136177
instance PluginMethod TextDocumentFormatting where
137178
type ExtraParams TextDocumentFormatting = (FormattingType, T.Text)
@@ -142,7 +183,7 @@ instance PluginMethod TextDocumentFormatting where
142183
Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
143184

144185
pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
145-
combineResponses _ _ _ _ (x :| _) = x
186+
combineResponses _ _ _ _ _ (x :| _) = x
146187

147188
instance PluginMethod TextDocumentRangeFormatting where
148189
type ExtraParams TextDocumentRangeFormatting = (FormattingType, T.Text)
@@ -153,7 +194,7 @@ instance PluginMethod TextDocumentRangeFormatting where
153194
Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
154195

155196
pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid
156-
combineResponses _ _ _ _ (x :| _) = x
197+
combineResponses _ _ _ _ _ (x :| _) = x
157198

158199
-- | Methods which have a PluginMethod instance
159200
data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m)
@@ -254,4 +295,25 @@ data FormattingType = FormatText
254295
responseError :: T.Text -> ResponseError
255296
responseError txt = ResponseError InvalidParams txt Nothing
256297

298+
-- ---------------------------------------------------------------------
299+
300+
data FallbackCodeActionParams =
301+
FallbackCodeActionParams
302+
{ fallbackWorkspaceEdit :: Maybe WorkspaceEdit
303+
, fallbackCommand :: Maybe Command
304+
}
305+
deriving (Generic, ToJSON, FromJSON)
306+
307+
-- ---------------------------------------------------------------------
308+
309+
mkLspCommand' :: T.Text -> PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command
310+
mkLspCommand' pid plid cn title args' = Command title cmdId args
311+
where
312+
cmdId = mkLspCmdId pid plid cn
313+
args = List <$> args'
314+
315+
mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
316+
mkLspCmdId pid (PluginId plid) (CommandId cid)
317+
= pid <> ":" <> plid <> ":" <> cid
318+
257319

0 commit comments

Comments
 (0)