Skip to content

Commit fce69dc

Browse files
awjchenawjchen
committed
Use restricted monad for plugins (#4057)
1 parent 7563439 commit fce69dc

File tree

25 files changed

+118
-93
lines changed

25 files changed

+118
-93
lines changed

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 (PluginM c) (MessageResult Method_TextDocumentDefinition)
47+
hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM c) (Hover |? Null)
48+
gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM c) (MessageResult Method_TextDocumentTypeDefinition)
49+
documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM 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 (PluginM 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 <- runPluginM (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 <- runPluginM $ 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 -> PluginM 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+
-> PluginM 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

+4-3
Original file line numberDiff line numberDiff line change
@@ -66,7 +66,9 @@ import Ide.Types (CommandFunction,
6666
defaultPluginDescriptor,
6767
mkCustomConfig,
6868
mkPluginHandler,
69-
mkResolveHandler)
69+
mkResolveHandler,
70+
pluginSendRequest,
71+
)
7072
import qualified Language.LSP.Protocol.Lens as L
7173
import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens),
7274
SMethod (..))
@@ -79,7 +81,6 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams
7981
TextEdit (TextEdit),
8082
WorkspaceEdit (WorkspaceEdit),
8183
type (|?) (..))
82-
import qualified Language.LSP.Server as LSP
8384
import Text.Regex.TDFA ((=~))
8485

8586
data Log = LogShake Shake.Log deriving Show
@@ -193,7 +194,7 @@ generateLensCommand pId uri title edit =
193194
-- and applies it.
194195
commandHandler :: CommandFunction IdeState WorkspaceEdit
195196
commandHandler _ideState _ wedit = do
196-
_ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
197+
_ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
197198
pure $ InR Null
198199

199200
--------------------------------------------------------------------------------

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 (PluginM 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 $

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

+54-8
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ module Ide.Types
3131
, PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId
3232
, PluginId(..)
3333
, PluginHandler(..), mkPluginHandler
34+
, PluginM, runPluginM, pluginGetClientCapabilities, pluginGetVirtualFile, pluginGetVersionedTextDoc, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress
3435
, PluginHandlers(..)
3536
, PluginMethod(..)
3637
, PluginMethodHandler
@@ -62,6 +63,7 @@ import Control.Lens (_Just, view, (.~), (?~), (^.),
6263
(^?))
6364
import Control.Monad (void)
6465
import Control.Monad.Error.Class (MonadError (throwError))
66+
import Control.Monad.IO.Class (MonadIO)
6567
import Control.Monad.Trans.Class (MonadTrans (lift))
6668
import Control.Monad.Trans.Except (ExceptT, runExceptT)
6769
import Data.Aeson hiding (Null, defaultOptions)
@@ -94,7 +96,7 @@ import Ide.Plugin.Properties
9496
import qualified Language.LSP.Protocol.Lens as L
9597
import Language.LSP.Protocol.Message
9698
import Language.LSP.Protocol.Types
97-
import Language.LSP.Server (LspM, LspT, getVirtualFile)
99+
import Language.LSP.Server
98100
import Language.LSP.VFS
99101
import Numeric.Natural
100102
import OpenTelemetry.Eventlog
@@ -103,6 +105,7 @@ import Prettyprinter as PP
103105
import System.FilePath
104106
import System.IO.Unsafe
105107
import Text.Regex.TDFA.Text ()
108+
import UnliftIO (MonadUnliftIO)
106109
-- ---------------------------------------------------------------------
107110

108111
data IdePlugins ideState = IdePlugins_
@@ -890,9 +893,52 @@ instance GEq IdeNotification where
890893
instance GCompare IdeNotification where
891894
gcompare (IdeNotification a) (IdeNotification b) = gcompare a b
892895

896+
-- | Restricted version of 'LspM' specific to plugins
897+
newtype PluginM config a = PluginM { _runPluginM :: LspM config a }
898+
deriving newtype (Applicative, Functor, Monad, MonadIO, MonadUnliftIO)
899+
900+
runPluginM :: PluginM config a -> LspM config a
901+
runPluginM = _runPluginM
902+
903+
-- | Wrapper of 'getVirtualFile' for PluginM
904+
--
905+
-- TODO: To be replaced by a lookup of the Shake build graph
906+
pluginGetVirtualFile :: NormalizedUri -> PluginM config (Maybe VirtualFile)
907+
pluginGetVirtualFile uri = PluginM $ getVirtualFile uri
908+
909+
-- | Version of 'getVersionedTextDoc' for PluginM
910+
--
911+
-- TODO: Should use 'pluginGetVirtualFile' instead of wrapping 'getVersionedTextDoc'.
912+
-- At the time of writing, 'pluginGetVirtualFile' of the "lsp" package is implemented with 'getVirtualFile'.
913+
pluginGetVersionedTextDoc :: TextDocumentIdentifier -> PluginM config VersionedTextDocumentIdentifier
914+
pluginGetVersionedTextDoc = PluginM . getVersionedTextDoc
915+
916+
-- | Wrapper of 'getClientCapabilities' for PluginM
917+
pluginGetClientCapabilities :: PluginM config ClientCapabilities
918+
pluginGetClientCapabilities = PluginM getClientCapabilities
919+
920+
-- | Wrapper of 'sendNotification for PluginM
921+
--
922+
-- TODO: Return notification in result instead of calling `sendNotification` directly
923+
pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> PluginM config ()
924+
pluginSendNotification smethod params = PluginM $ sendNotification smethod params
925+
926+
-- | Wrapper of 'sendRequest' for PluginM
927+
--
928+
-- TODO: Return request in result instead of calling `sendRequest` directly
929+
pluginSendRequest :: forall (m :: Method ServerToClient Request) config. SServerMethod m -> MessageParams m -> (Either (TResponseError m) (MessageResult m) -> PluginM config ()) -> PluginM config (LspId m)
930+
pluginSendRequest smethod params action = PluginM $ sendRequest smethod params (runPluginM . action)
931+
932+
-- | Wrapper of 'withIndefiniteProgress' for PluginM
933+
pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> PluginM config ()) -> PluginM config a) -> PluginM config a
934+
pluginWithIndefiniteProgress title progressToken cancellable updateAction =
935+
PluginM $
936+
withIndefiniteProgress title progressToken cancellable $ \putUpdate ->
937+
runPluginM $ updateAction (PluginM . putUpdate)
938+
893939
-- | Combine handlers for the
894940
newtype PluginHandler a (m :: Method ClientToServer Request)
895-
= PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))
941+
= PluginHandler (PluginId -> a -> MessageParams m -> PluginM Config (NonEmpty (Either PluginError (MessageResult m))))
896942

897943
newtype PluginNotificationHandler a (m :: Method ClientToServer Notification)
898944
= PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
@@ -917,7 +963,7 @@ instance Semigroup (PluginNotificationHandlers a) where
917963
instance Monoid (PluginNotificationHandlers a) where
918964
mempty = PluginNotificationHandlers mempty
919965

920-
type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m)
966+
type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (PluginM Config) (MessageResult m)
921967

922968
type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config ()
923969

@@ -930,7 +976,7 @@ mkPluginHandler
930976
-> PluginHandlers ideState
931977
mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m))
932978
where
933-
f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))
979+
f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> PluginM Config (NonEmpty (Either PluginError (MessageResult m)))
934980
-- We need to have separate functions for each method that supports resolve, so far we only support CodeActions
935981
-- CodeLens, and Completion methods.
936982
f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} =
@@ -1034,7 +1080,7 @@ type CommandFunction ideState a
10341080
= ideState
10351081
-> Maybe ProgressToken
10361082
-> a
1037-
-> ExceptT PluginError (LspM Config) (Value |? Null)
1083+
-> ExceptT PluginError (PluginM Config) (Value |? Null)
10381084

10391085
-- ---------------------------------------------------------------------
10401086

@@ -1044,7 +1090,7 @@ type ResolveFunction ideState a (m :: Method ClientToServer Request) =
10441090
-> MessageParams m
10451091
-> Uri
10461092
-> a
1047-
-> ExceptT PluginError (LspM Config) (MessageResult m)
1093+
-> ExceptT PluginError (PluginM Config) (MessageResult m)
10481094

10491095
-- | Make a handler for resolve methods. In here we take your provided ResolveFunction
10501096
-- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]
@@ -1126,7 +1172,7 @@ type FormattingHandler a
11261172
-> T.Text
11271173
-> NormalizedFilePath
11281174
-> FormattingOptions
1129-
-> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
1175+
-> ExceptT PluginError (PluginM Config) ([TextEdit] |? Null)
11301176

11311177
mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
11321178
mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)
@@ -1135,7 +1181,7 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid
11351181
provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m
11361182
provider m ide _pid params
11371183
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
1138-
mf <- lift $ getVirtualFile $ toNormalizedUri uri
1184+
mf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri
11391185
case mf of
11401186
Just vf -> do
11411187
let (typ, mtoken) = case m of

Diff for: ‎plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

+1-2
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,6 @@ import Ide.Types
4343
import qualified Language.LSP.Protocol.Lens as JL
4444
import qualified Language.LSP.Protocol.Message as LSP
4545
import Language.LSP.Protocol.Types
46-
import Language.LSP.Server (getVirtualFile)
4746
import qualified Language.LSP.VFS as VFS
4847

4948
data Log
@@ -311,7 +310,7 @@ completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.M
311310
completion recorder ide _ complParams = do
312311
let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument
313312
position = complParams ^. JL.position
314-
mVf <- lift $ getVirtualFile $ toNormalizedUri uri
313+
mVf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri
315314
case (,) <$> mVf <*> uriToFilePath' uri of
316315
Just (cnts, path) -> do
317316
mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ide) $ useWithStaleFast ParseCabalFields $ toNormalizedFilePath path

0 commit comments

Comments
 (0)