Skip to content

Commit cebd641

Browse files
awjchenawjchen
authored
Use restricted monad for plugins (#4057) (#4304)
* Use restricted monad for plugins (#4057) * Renaming: PluginM -> HandlerM * Explain intent for HandlerM * Fix comment * Apply stylish-haskell
1 parent 59abb96 commit cebd641

File tree

26 files changed

+172
-135
lines changed

26 files changed

+172
-135
lines changed

Diff for: ‎ghcide/src/Development/IDE/Core/Rules.hs

+6-4
Original file line numberDiff line numberDiff line change
@@ -147,14 +147,13 @@ import Ide.Logger (Pretty (pretty),
147147
import qualified Ide.Logger as Logger
148148
import Ide.Plugin.Config
149149
import Ide.Plugin.Properties (HasProperty,
150-
KeyNameProxy,
150+
HasPropertyByPath,
151151
KeyNamePath,
152+
KeyNameProxy,
152153
Properties,
153154
ToHsType,
154155
useProperty,
155-
usePropertyByPath,
156-
HasPropertyByPath
157-
)
156+
usePropertyByPath)
158157
import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
159158
PluginId)
160159
import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage))
@@ -226,6 +225,9 @@ toIdeResult = either (, Nothing) (([],) . Just)
226225
------------------------------------------------------------
227226
-- Exposed API
228227
------------------------------------------------------------
228+
229+
-- TODO: rename
230+
-- TODO: return text --> return rope
229231
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
230232
getSourceFileSource nfp = do
231233
(_, msource) <- getFileContents nfp

Diff for: ‎ghcide/src/Development/IDE/LSP/HoverDefinition.hs

+5-6
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,6 @@ import Ide.Plugin.Error
2727
import Ide.Types
2828
import Language.LSP.Protocol.Message
2929
import Language.LSP.Protocol.Types
30-
import qualified Language.LSP.Server as LSP
3130

3231
import qualified Data.Text as T
3332

@@ -44,10 +43,10 @@ instance Pretty Log where
4443
pretty label <+> "request at position" <+> pretty (showPosition pos) <+>
4544
"in file:" <+> pretty (fromNormalizedFilePath nfp)
4645

47-
gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
48-
hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
49-
gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
50-
documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
46+
gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition)
47+
hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)
48+
gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)
49+
documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
5150
gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)
5251
gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)
5352
hover = request "Hover" getAtPoint (InR Null) foundHover
@@ -77,7 +76,7 @@ request
7776
-> Recorder (WithPriority Log)
7877
-> IdeState
7978
-> TextDocumentPositionParams
80-
-> ExceptT PluginError (LSP.LspM c) b
79+
-> ExceptT PluginError (HandlerM c) b
8180
request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
8281
mbResult <- case uriToFilePath' uri of
8382
Just path -> logAndRunRequest recorder label getResults ide pos path

Diff for: ‎ghcide/src/Development/IDE/Plugin/Completions.hs

+1-2
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,6 @@ import Ide.Types
4747
import qualified Language.LSP.Protocol.Lens as L
4848
import Language.LSP.Protocol.Message
4949
import Language.LSP.Protocol.Types
50-
import qualified Language.LSP.Server as LSP
5150
import Numeric.Natural
5251
import Prelude hiding (mod)
5352
import Text.Fuzzy.Parallel (Scored (..))
@@ -170,7 +169,7 @@ getCompletionsLSP ide plId
170169
CompletionParams{_textDocument=TextDocumentIdentifier uri
171170
,_position=position
172171
,_context=completionContext} = ExceptT $ do
173-
contents <- LSP.getVirtualFile $ toNormalizedUri uri
172+
contents <- pluginGetVirtualFile $ toNormalizedUri uri
174173
fmap Right $ case (contents, uriToFilePath' uri) of
175174
(Just cnts, Just path) -> do
176175
let npath = toNormalizedFilePath' path

Diff for: ‎ghcide/src/Development/IDE/Plugin/HLS.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -219,7 +219,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom
219219
Just (PluginCommand _ _ f) -> case A.fromJSON arg of
220220
A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)
221221
A.Success a -> do
222-
res <- runExceptT (f ide mtoken a) `catchAny` -- See Note [Exception handling in plugins]
222+
res <- runHandlerM (runExceptT (f ide mtoken a)) `catchAny` -- See Note [Exception handling in plugins]
223223
(\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))
224224
case res of
225225
(Left (PluginRequestRefused r)) ->
@@ -254,7 +254,7 @@ extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers }
254254
Nothing -> liftIO $ noPluginHandles recorder m disabledPluginsReason
255255
Just neFs -> do
256256
let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs
257-
es <- runConcurrently exceptionInPlugin m plidsAndHandlers ide params
257+
es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params
258258
caps <- LSP.getClientCapabilities
259259
let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es
260260
liftIO $ unless (null errs) $ logErrors recorder errs
@@ -335,7 +335,7 @@ logErrors recorder errs = do
335335

336336
-- | Combine the 'PluginHandler' for all plugins
337337
newtype IdeHandler (m :: Method ClientToServer Request)
338-
= IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
338+
= IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))]
339339

340340
-- | Combine the 'PluginHandler' for all plugins
341341
newtype IdeNotificationHandler (m :: Method ClientToServer Notification)

Diff for: ‎ghcide/src/Development/IDE/Plugin/Test.hs

+3-4
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,6 @@ import Ide.Plugin.Error
4949
import Ide.Types
5050
import Language.LSP.Protocol.Message
5151
import Language.LSP.Protocol.Types
52-
import qualified Language.LSP.Server as LSP
5352
import qualified "list-t" ListT
5453
import qualified StmContainers.Map as STM
5554
import System.Time.Extra
@@ -91,9 +90,9 @@ plugin = (defaultPluginDescriptor "test" "") {
9190

9291
testRequestHandler :: IdeState
9392
-> TestRequest
94-
-> LSP.LspM c (Either PluginError Value)
93+
-> HandlerM config (Either PluginError Value)
9594
testRequestHandler _ (BlockSeconds secs) = do
96-
LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $
95+
pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $
9796
toJSON secs
9897
liftIO $ sleep secs
9998
return (Right A.Null)
@@ -171,6 +170,6 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId "") {
171170

172171
blockCommandHandler :: CommandFunction state ExecuteCommandParams
173172
blockCommandHandler _ideState _ _params = do
174-
lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null
173+
lift $ pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null
175174
liftIO $ threadDelay maxBound
176175
pure $ InR Null

Diff for: ‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -66,7 +66,8 @@ import Ide.Types (CommandFunction,
6666
defaultPluginDescriptor,
6767
mkCustomConfig,
6868
mkPluginHandler,
69-
mkResolveHandler)
69+
mkResolveHandler,
70+
pluginSendRequest)
7071
import qualified Language.LSP.Protocol.Lens as L
7172
import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens),
7273
SMethod (..))
@@ -79,7 +80,6 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams
7980
TextEdit (TextEdit),
8081
WorkspaceEdit (WorkspaceEdit),
8182
type (|?) (..))
82-
import qualified Language.LSP.Server as LSP
8383
import Text.Regex.TDFA ((=~))
8484

8585
data Log = LogShake Shake.Log deriving Show
@@ -193,7 +193,7 @@ generateLensCommand pId uri title edit =
193193
-- and applies it.
194194
commandHandler :: CommandFunction IdeState WorkspaceEdit
195195
commandHandler _ideState _ wedit = do
196-
_ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
196+
_ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
197197
pure $ InR Null
198198

199199
--------------------------------------------------------------------------------

Diff for: ‎hls-plugin-api/src/Ide/Plugin/Resolve.hs

+4-6
Original file line numberDiff line numberDiff line change
@@ -33,8 +33,6 @@ import Ide.Types
3333
import qualified Language.LSP.Protocol.Lens as L
3434
import Language.LSP.Protocol.Message
3535
import Language.LSP.Protocol.Types
36-
import Language.LSP.Server (LspT, getClientCapabilities,
37-
sendRequest)
3836

3937
data Log
4038
= DoesNotSupportResolve T.Text
@@ -60,7 +58,7 @@ mkCodeActionHandlerWithResolve
6058
mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =
6159
let newCodeActionMethod ideState pid params =
6260
do codeActionReturn <- codeActionMethod ideState pid params
63-
caps <- lift getClientCapabilities
61+
caps <- lift pluginGetClientCapabilities
6462
case codeActionReturn of
6563
r@(InR Null) -> pure r
6664
(InL ls) | -- We don't need to do anything if the client supports
@@ -74,7 +72,7 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =
7472
<> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)
7573
where dropData :: CodeAction -> CodeAction
7674
dropData ca = ca & L.data_ .~ Nothing
77-
resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction)
75+
resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (HandlerM Config) (Command |? CodeAction)
7876
resolveCodeAction _uri _ideState _plId c@(InL _) = pure c
7977
resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do
8078
case A.fromJSON value of
@@ -105,7 +103,7 @@ mkCodeActionWithResolveAndCommand
105103
mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod =
106104
let newCodeActionMethod ideState pid params =
107105
do codeActionReturn <- codeActionMethod ideState pid params
108-
caps <- lift getClientCapabilities
106+
caps <- lift pluginGetClientCapabilities
109107
case codeActionReturn of
110108
r@(InR Null) -> pure r
111109
(InL ls) | -- We don't need to do anything if the client supports
@@ -145,7 +143,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth
145143
resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded
146144
case resolveResult of
147145
ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do
148-
_ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback
146+
_ <- ExceptT $ Right <$> pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback
149147
pure $ InR Null
150148
ca2@CodeAction {_edit = Just _ } ->
151149
throwError $ internalError $

0 commit comments

Comments
 (0)