Use restricted monad for plugins (#4057)

ghcide/src/Development/IDE/LSP/HoverDefinition.hs

@@ -27,7 +27,6 @@ import           Ide.Plugin.Error
 import           Ide.Types
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Server            as LSP
 
 import qualified Data.Text                      as T
 
@@ -44,10 +43,10 @@ instance Pretty Log where
       pretty label <+> "request at position" <+> pretty (showPosition pos) <+>
         "in file:" <+> pretty (fromNormalizedFilePath nfp)
 
-gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
-hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
-gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
-documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
+gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM c) (MessageResult Method_TextDocumentDefinition)
+hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM c) (Hover |? Null)
+gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM c) (MessageResult Method_TextDocumentTypeDefinition)
+documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (PluginM c) ([DocumentHighlight] |? Null)
 gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)
 gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)
 hover          = request "Hover"      getAtPoint     (InR Null)     foundHover
@@ -77,7 +76,7 @@ request
   -> Recorder (WithPriority Log)
   -> IdeState
   -> TextDocumentPositionParams
-  -> ExceptT PluginError (LSP.LspM c) b
+  -> ExceptT PluginError (PluginM c) b
 request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do
     mbResult <- case uriToFilePath' uri of
         Just path -> logAndRunRequest recorder label getResults ide pos path

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -47,7 +47,6 @@ import           Ide.Types
 import qualified Language.LSP.Protocol.Lens               as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Server                      as LSP
 import           Numeric.Natural
 import           Prelude                                  hiding (mod)
 import           Text.Fuzzy.Parallel                      (Scored (..))
@@ -170,7 +169,7 @@ getCompletionsLSP ide plId
   CompletionParams{_textDocument=TextDocumentIdentifier uri
                   ,_position=position
                   ,_context=completionContext} = ExceptT $ do
-    contents <- LSP.getVirtualFile $ toNormalizedUri uri
+    contents <- pluginGetVirtualFile $ toNormalizedUri uri
     fmap Right $ case (contents, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath' path

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

@@ -219,7 +219,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom
           Just (PluginCommand _ _ f) -> case A.fromJSON arg of
             A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)
             A.Success a -> do
-              res <- runExceptT (f ide mtoken a) `catchAny` -- See Note [Exception handling in plugins]
+              res <- runPluginM (runExceptT (f ide mtoken a)) `catchAny` -- See Note [Exception handling in plugins]
                 (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))
               case res of
                 (Left (PluginRequestRefused r)) ->
@@ -254,7 +254,7 @@ extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers }
           Nothing -> liftIO $ noPluginHandles recorder m disabledPluginsReason
           Just neFs -> do
             let  plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs
-            es <- runConcurrently exceptionInPlugin m plidsAndHandlers ide params
+            es <- runPluginM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params
             caps <- LSP.getClientCapabilities
             let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es
             liftIO $ unless (null errs) $ logErrors recorder errs
@@ -335,7 +335,7 @@ logErrors recorder errs = do
 
 -- | Combine the 'PluginHandler' for all plugins
 newtype IdeHandler (m :: Method ClientToServer Request)
-  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
+  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> PluginM Config (NonEmpty (Either PluginError (MessageResult m))))]
 
 -- | Combine the 'PluginHandler' for all plugins
 newtype IdeNotificationHandler (m :: Method ClientToServer Notification)

ghcide/src/Development/IDE/Plugin/Test.hs

@@ -49,7 +49,6 @@ import           Ide.Plugin.Error
 import           Ide.Types
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Server                  as LSP
 import qualified "list-t" ListT
 import qualified StmContainers.Map                    as STM
 import           System.Time.Extra
@@ -91,9 +90,9 @@ plugin = (defaultPluginDescriptor "test" "") {
 
 testRequestHandler ::  IdeState
                 -> TestRequest
-                -> LSP.LspM c (Either PluginError Value)
+                -> PluginM config (Either PluginError Value)
 testRequestHandler _ (BlockSeconds secs) = do
-    LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $
+    pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $
       toJSON secs
     liftIO $ sleep secs
     return (Right A.Null)
@@ -171,6 +170,6 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId "") {
 
 blockCommandHandler :: CommandFunction state ExecuteCommandParams
 blockCommandHandler _ideState _ _params = do
-  lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null
+  lift $ pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null
   liftIO $ threadDelay maxBound
   pure $ InR Null

ghcide/src/Development/IDE/Plugin/TypeLenses.hs

@@ -66,7 +66,9 @@ import           Ide.Types                            (CommandFunction,
                                                        defaultPluginDescriptor,
                                                        mkCustomConfig,
                                                        mkPluginHandler,
-                                                       mkResolveHandler)
+                                                       mkResolveHandler,
+                                                       pluginSendRequest,
+                                                       )
 import qualified Language.LSP.Protocol.Lens           as L
 import           Language.LSP.Protocol.Message        (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens),
                                                        SMethod (..))
@@ -79,7 +81,6 @@ import           Language.LSP.Protocol.Types          (ApplyWorkspaceEditParams
                                                        TextEdit (TextEdit),
                                                        WorkspaceEdit (WorkspaceEdit),
                                                        type (|?) (..))
-import qualified Language.LSP.Server                  as LSP
 import           Text.Regex.TDFA                      ((=~))
 
 data Log = LogShake Shake.Log deriving Show
@@ -193,7 +194,7 @@ generateLensCommand pId uri title edit =
 -- and applies it.
 commandHandler :: CommandFunction IdeState WorkspaceEdit
 commandHandler _ideState _ wedit = do
-  _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
+  _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
   pure $ InR Null
 
 --------------------------------------------------------------------------------

hls-plugin-api/src/Ide/Plugin/Resolve.hs

@@ -33,8 +33,6 @@ import           Ide.Types
 import qualified Language.LSP.Protocol.Lens    as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import           Language.LSP.Server           (LspT, getClientCapabilities,
-                                                sendRequest)
 
 data Log
     = DoesNotSupportResolve T.Text
@@ -60,7 +58,7 @@ mkCodeActionHandlerWithResolve
 mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =
   let newCodeActionMethod ideState pid params =
         do codeActionReturn <- codeActionMethod ideState pid params
-           caps <- lift getClientCapabilities
+           caps <- lift pluginGetClientCapabilities
            case codeActionReturn of
              r@(InR Null) -> pure r
              (InL ls) | -- We don't need to do anything if the client supports
@@ -74,7 +72,7 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =
   <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)
   where dropData :: CodeAction -> CodeAction
         dropData ca = ca & L.data_ .~ Nothing
-        resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction)
+        resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (PluginM Config) (Command |? CodeAction)
         resolveCodeAction _uri _ideState _plId c@(InL _) = pure c
         resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do
           case A.fromJSON value of
@@ -105,7 +103,7 @@ mkCodeActionWithResolveAndCommand
 mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod =
   let newCodeActionMethod ideState pid params =
         do codeActionReturn <- codeActionMethod ideState pid params
-           caps <- lift getClientCapabilities
+           caps <- lift pluginGetClientCapabilities
            case codeActionReturn of
              r@(InR Null) -> pure r
              (InL ls) | -- We don't need to do anything if the client supports
@@ -145,7 +143,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth
                   resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded
                   case resolveResult of
                     ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do
-                        _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback
+                        _ <- ExceptT $ Right <$> pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback
                         pure $ InR Null
                     ca2@CodeAction {_edit = Just _ }  ->
                       throwError $ internalError $

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

@@ -31,6 +31,7 @@ module Ide.Types
 , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId
 , PluginId(..)
 , PluginHandler(..), mkPluginHandler
+, PluginM, runPluginM, pluginGetClientCapabilities, pluginGetVirtualFile, pluginGetVersionedTextDoc, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress
 , PluginHandlers(..)
 , PluginMethod(..)
 , PluginMethodHandler
@@ -62,6 +63,7 @@ import           Control.Lens                  (_Just, view, (.~), (?~), (^.),
                                                 (^?))
 import           Control.Monad                 (void)
 import           Control.Monad.Error.Class     (MonadError (throwError))
+import           Control.Monad.IO.Class        (MonadIO)
 import           Control.Monad.Trans.Class     (MonadTrans (lift))
 import           Control.Monad.Trans.Except    (ExceptT, runExceptT)
 import           Data.Aeson                    hiding (Null, defaultOptions)
@@ -94,7 +96,7 @@ import           Ide.Plugin.Properties
 import qualified Language.LSP.Protocol.Lens    as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import           Language.LSP.Server           (LspM, LspT, getVirtualFile)
+import           Language.LSP.Server
 import           Language.LSP.VFS
 import           Numeric.Natural
 import           OpenTelemetry.Eventlog
@@ -103,6 +105,7 @@ import           Prettyprinter                 as PP
 import           System.FilePath
 import           System.IO.Unsafe
 import           Text.Regex.TDFA.Text          ()
+import           UnliftIO                      (MonadUnliftIO)
 -- ---------------------------------------------------------------------
 
 data IdePlugins ideState = IdePlugins_
@@ -890,9 +893,52 @@ instance GEq IdeNotification where
 instance GCompare IdeNotification where
   gcompare (IdeNotification a) (IdeNotification b) = gcompare a b
 
+-- | Restricted version of 'LspM' specific to plugins
+newtype PluginM config a = PluginM { _runPluginM :: LspM config a }
+  deriving newtype (Applicative, Functor, Monad, MonadIO, MonadUnliftIO)
+
+runPluginM :: PluginM config a -> LspM config a
+runPluginM = _runPluginM
+
+-- | Wrapper of 'getVirtualFile' for PluginM
+--
+-- TODO: To be replaced by a lookup of the Shake build graph
+pluginGetVirtualFile :: NormalizedUri -> PluginM config (Maybe VirtualFile)
+pluginGetVirtualFile uri = PluginM $ getVirtualFile uri
+
+-- | Version of 'getVersionedTextDoc' for PluginM
+--
+-- TODO: Should use 'pluginGetVirtualFile' instead of wrapping 'getVersionedTextDoc'.
+-- At the time of writing, 'pluginGetVirtualFile' of the "lsp" package is implemented with 'getVirtualFile'.
+pluginGetVersionedTextDoc :: TextDocumentIdentifier -> PluginM config VersionedTextDocumentIdentifier
+pluginGetVersionedTextDoc = PluginM . getVersionedTextDoc
+
+-- | Wrapper of 'getClientCapabilities' for PluginM
+pluginGetClientCapabilities :: PluginM config ClientCapabilities
+pluginGetClientCapabilities = PluginM getClientCapabilities
+
+-- | Wrapper of 'sendNotification for PluginM
+--
+-- TODO: Return notification in result instead of calling `sendNotification` directly
+pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> PluginM config ()
+pluginSendNotification smethod params = PluginM $ sendNotification smethod params
+
+-- | Wrapper of 'sendRequest' for PluginM
+--
+-- TODO: Return request in result instead of calling `sendRequest` directly
+pluginSendRequest :: forall (m :: Method ServerToClient Request) config. SServerMethod m -> MessageParams m -> (Either (TResponseError m) (MessageResult m) -> PluginM config ()) -> PluginM config (LspId m)
+pluginSendRequest smethod params action = PluginM $ sendRequest smethod params (runPluginM . action)
+
+-- | Wrapper of 'withIndefiniteProgress' for PluginM
+pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> PluginM config ()) -> PluginM config a) -> PluginM config a
+pluginWithIndefiniteProgress title progressToken cancellable updateAction =
+  PluginM $
+    withIndefiniteProgress title progressToken cancellable $ \putUpdate ->
+      runPluginM $ updateAction (PluginM . putUpdate)
+
 -- | Combine handlers for the
 newtype PluginHandler a (m :: Method ClientToServer Request)
-  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))
+  = PluginHandler (PluginId -> a -> MessageParams m -> PluginM Config (NonEmpty (Either PluginError (MessageResult m))))
 
 newtype PluginNotificationHandler a (m :: Method ClientToServer Notification)
   = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
@@ -917,7 +963,7 @@ instance Semigroup (PluginNotificationHandlers a) where
 instance Monoid (PluginNotificationHandlers a) where
   mempty = PluginNotificationHandlers mempty
 
-type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m)
+type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (PluginM Config) (MessageResult m)
 
 type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config ()
 
@@ -930,7 +976,7 @@ mkPluginHandler
   -> PluginHandlers ideState
 mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m))
   where
-    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))
+    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> PluginM Config (NonEmpty (Either PluginError (MessageResult m)))
     -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions
     -- CodeLens, and Completion methods.
     f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} =
@@ -1034,7 +1080,7 @@ type CommandFunction ideState a
   = ideState
   -> Maybe ProgressToken
   -> a
-  -> ExceptT PluginError (LspM Config) (Value |? Null)
+  -> ExceptT PluginError (PluginM Config) (Value |? Null)
 
 -- ---------------------------------------------------------------------
 
@@ -1044,7 +1090,7 @@ type ResolveFunction ideState a (m :: Method ClientToServer Request) =
   -> MessageParams m
   -> Uri
   -> a
-  -> ExceptT PluginError (LspM Config) (MessageResult m)
+  -> ExceptT PluginError (PluginM Config) (MessageResult m)
 
 -- | Make a handler for resolve methods. In here we take your provided ResolveFunction
 -- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]
@@ -1126,7 +1172,7 @@ type FormattingHandler a
   -> T.Text
   -> NormalizedFilePath
   -> FormattingOptions
-  -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)
+  -> ExceptT PluginError (PluginM Config) ([TextEdit] |? Null)
 
 mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
 mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)
@@ -1135,7 +1181,7 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid
     provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m
     provider m ide _pid params
       | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
-        mf <- lift $ getVirtualFile $ toNormalizedUri uri
+        mf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri
         case mf of
           Just vf -> do
             let (typ, mtoken) = case m of

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

@@ -43,7 +43,6 @@ import           Ide.Types
 import qualified Language.LSP.Protocol.Lens                  as JL
 import qualified Language.LSP.Protocol.Message               as LSP
 import           Language.LSP.Protocol.Types
-import           Language.LSP.Server                         (getVirtualFile)
 import qualified Language.LSP.VFS                            as VFS
 
 data Log
@@ -311,7 +310,7 @@ completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.M
 completion recorder ide _ complParams = do
   let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument
       position = complParams ^. JL.position
-  mVf <- lift $ getVirtualFile $ toNormalizedUri uri
+  mVf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri
   case (,) <$> mVf <*> uriToFilePath' uri of
     Just (cnts, path) -> do
       mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ide) $ useWithStaleFast ParseCabalFields $ toNormalizedFilePath path