diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index c38a1cae3a..a10323f3fe 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -147,14 +147,13 @@ import Ide.Logger (Pretty (pretty), import qualified Ide.Logger as Logger import Ide.Plugin.Config import Ide.Plugin.Properties (HasProperty, - KeyNameProxy, + HasPropertyByPath, KeyNamePath, + KeyNameProxy, Properties, ToHsType, useProperty, - usePropertyByPath, - HasPropertyByPath - ) + usePropertyByPath) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) @@ -226,6 +225,9 @@ toIdeResult = either (, Nothing) (([],) . Just) ------------------------------------------------------------ -- Exposed API ------------------------------------------------------------ + +-- TODO: rename +-- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do (_, msource) <- getFileContents nfp diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 9c8876a554..aea3449bf3 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/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 (HandlerM c) (MessageResult Method_TextDocumentDefinition) +hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) +gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM 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 (HandlerM 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 diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 7f68fc2599..ad9f4fe6f5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 3f1c19d1a2..fd48d86ae6 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/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 <- runHandlerM (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 <- runHandlerM $ 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 -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))] -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: Method ClientToServer Notification) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 5dfc8460b0..e24bcfeee9 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/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) + -> HandlerM 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 diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 040f49f904..51d25e995b 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -66,7 +66,8 @@ 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 +80,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 +193,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 -------------------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 3a3638c12b..36c61baaff 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/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 (HandlerM 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 $ diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 5212b2c6da..e3ef9de47f 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -31,6 +31,7 @@ module Ide.Types , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId , PluginId(..) , PluginHandler(..), mkPluginHandler +, HandlerM, runHandlerM, 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,57 @@ instance GEq IdeNotification where instance GCompare IdeNotification where gcompare (IdeNotification a) (IdeNotification b) = gcompare a b +-- | Restricted version of 'LspM' specific to plugins. +-- +-- We plan to use this monad for running plugins instead of 'LspM', since there +-- are parts of the LSP server state which plugins should not access directly, +-- but instead only via the build system. Note that this restriction of the LSP +-- server state has not yet been implemented. See 'pluginGetVirtualFile'. +newtype HandlerM config a = HandlerM { _runHandlerM :: LspM config a } + deriving newtype (Applicative, Functor, Monad, MonadIO, MonadUnliftIO) + +runHandlerM :: HandlerM config a -> LspM config a +runHandlerM = _runHandlerM + +-- | Wrapper of 'getVirtualFile' for HandlerM +-- +-- TODO: To be replaced by a lookup of the Shake build graph +pluginGetVirtualFile :: NormalizedUri -> HandlerM config (Maybe VirtualFile) +pluginGetVirtualFile uri = HandlerM $ getVirtualFile uri + +-- | Version of 'getVersionedTextDoc' for HandlerM +-- +-- TODO: Should use 'pluginGetVirtualFile' instead of wrapping 'getVersionedTextDoc'. +-- At the time of writing, 'getVersionedTextDoc' of the "lsp" package is implemented with 'getVirtualFile'. +pluginGetVersionedTextDoc :: TextDocumentIdentifier -> HandlerM config VersionedTextDocumentIdentifier +pluginGetVersionedTextDoc = HandlerM . getVersionedTextDoc + +-- | Wrapper of 'getClientCapabilities' for HandlerM +pluginGetClientCapabilities :: HandlerM config ClientCapabilities +pluginGetClientCapabilities = HandlerM getClientCapabilities + +-- | Wrapper of 'sendNotification for HandlerM +-- +-- TODO: Return notification in result instead of calling `sendNotification` directly +pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> HandlerM config () +pluginSendNotification smethod params = HandlerM $ sendNotification smethod params + +-- | Wrapper of 'sendRequest' for HandlerM +-- +-- 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) -> HandlerM config ()) -> HandlerM config (LspId m) +pluginSendRequest smethod params action = HandlerM $ sendRequest smethod params (runHandlerM . action) + +-- | Wrapper of 'withIndefiniteProgress' for HandlerM +pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> HandlerM config ()) -> HandlerM config a) -> HandlerM config a +pluginWithIndefiniteProgress title progressToken cancellable updateAction = + HandlerM $ + withIndefiniteProgress title progressToken cancellable $ \putUpdate -> + runHandlerM $ updateAction (HandlerM . 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 -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m)))) newtype PluginNotificationHandler a (m :: Method ClientToServer Notification) = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ()) @@ -917,7 +968,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 (HandlerM Config) (MessageResult m) type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -930,7 +981,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 -> HandlerM 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 +1085,7 @@ type CommandFunction ideState a = ideState -> Maybe ProgressToken -> a - -> ExceptT PluginError (LspM Config) (Value |? Null) + -> ExceptT PluginError (HandlerM Config) (Value |? Null) -- --------------------------------------------------------------------- @@ -1044,7 +1095,7 @@ type ResolveFunction ideState a (m :: Method ClientToServer Request) = -> MessageParams m -> Uri -> a - -> ExceptT PluginError (LspM Config) (MessageResult m) + -> ExceptT PluginError (HandlerM 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 +1177,7 @@ type FormattingHandler a -> T.Text -> NormalizedFilePath -> FormattingOptions - -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null) + -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null) mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting) @@ -1135,7 +1186,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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 40892b8b12..3c14196459 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/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 -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index ad17c1409a..fa2a1dd46c 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -39,11 +39,10 @@ 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 addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do - caps <- lift getClientCapabilities + caps <- lift pluginGetClientCapabilities nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state $ useE GetParsedModule nfp @@ -58,7 +57,7 @@ addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do then mergeEdit (workspaceEdit caps old new) pragmaInsertion else workspaceEdit caps old new - void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure $ InR Null where @@ -81,7 +80,7 @@ addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do -- sensitive to the format of diagnostic messages from GHC. codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do - verTxtDocId <- lift $ getVersionedTextDoc docId + verTxtDocId <- lift $ pluginGetVersionedTextDoc docId nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags pure $ InL actions @@ -95,7 +94,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do :: NormalizedFilePath -> VersionedTextDocumentIdentifier -> Diagnostic - -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] + -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction] mkActions docPath verTxtDocId diag = do (HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state $ useWithStaleE GetHieAst docPath @@ -166,7 +165,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do findImplementedMethods :: HieASTs a -> Position - -> ExceptT PluginError (LspT Ide.Plugin.Config.Config IO) [T.Text] + -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [T.Text] findImplementedMethods asts instancePosition = do pure $ concat diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 6b009b272d..9410469516 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -23,7 +23,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 (sendRequest) -- The code lens method is only responsible for providing the ranges of the code -- lenses matched to a unique id @@ -83,7 +82,7 @@ codeLensCommandHandler plId state _ InstanceBindLensCommand{commandUri, commandE pragmaInsertion = maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma wEdit = workspaceEdit pragmaInsertion - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ()) + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ()) pure $ InR Null where workspaceEdit pragmaInsertion= diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 8701526b65..4d9ace1163 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -203,7 +203,7 @@ runEvalCmd :: Recorder (WithPriority Log) -> PluginId -> CommandFunction IdeStat runEvalCmd recorder plId st mtoken EvalParams{..} = let dbg = logWith recorder Debug perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration) - cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit + cmd :: ExceptT PluginError (HandlerM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections @@ -238,7 +238,7 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = return workspaceEdits in perf "evalCmd" $ ExceptT $ - withIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater -> + pluginWithIndefiniteProgress "Evaluating" mtoken Cancellable $ \_updater -> runExceptT $ response' cmd -- | Create an HscEnv which is suitable for performing interactive evaluation. @@ -305,11 +305,11 @@ finalReturn txt = p = Position l c in TextEdit (Range p p) "\n" -moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text +moduleText :: Uri -> ExceptT PluginError (HandlerM config) Text moduleText uri = handleMaybeM (PluginInternalError "mdlText") $ (virtualFileText <$>) - <$> getVirtualFile + <$> pluginGetVirtualFile (toNormalizedUri uri) testsBySection :: [Section] -> [(Section, EvalId, Test)] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index eb8a47a949..14b47f4d95 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -38,6 +38,8 @@ import GHC.Stack (HasCallStack, callStack, srcLocStartCol, srcLocStartLine) import Ide.Plugin.Error +import Ide.Types (HandlerM, + pluginSendRequest) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server @@ -55,13 +57,13 @@ timed out name op = do isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null) +response' :: ExceptT PluginError (HandlerM c) WorkspaceEdit -> ExceptT PluginError (HandlerM c) (Value |? Null) response' act = do res <- ExceptT (runExceptT act `catchAny` \e -> do res <- showErr e pure . Left . PluginInternalError $ fromString res) - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) pure $ InR Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 8c7154e912..c3e6de6091 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -52,7 +52,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 -- This plugin is named explicit-imports for historical reasons. Besides -- providing code actions and lenses to make imports explicit it also provides @@ -107,7 +106,7 @@ descriptorForModules recorder modFilter plId = runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do wedit <- resolveWTextEdit ideState eird - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors return $ InR Null where logErrors (Left re) = do logWith recorder Error (LogWAEResponseError re) @@ -212,7 +211,7 @@ codeActionResolveProvider _ ideState _ ca _ rd = do pure $ ca & L.edit ?~ wedit -------------------------------------------------------------------------------- -resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (LspT Config IO) WorkspaceEdit +resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (HandlerM Config) WorkspaceEdit -- Providing the edit for the command, or the resolve for the code action is -- completely generic, as all we need is the unique id and the text edit. resolveWTextEdit ideState (ResolveOne uri int) = do diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index f8ed5871e9..0f162d5af9 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -66,7 +66,7 @@ properties = False provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState -provider recorder plId ideState token typ contents fp fo = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do +provider recorder plId ideState token typ contents fp fo = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do fileOpts <- maybe [] (convertDynFlags . hsc_dflags . hscEnv) <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp) @@ -87,7 +87,7 @@ provider recorder plId ideState token typ contents fp fo = ExceptT $ withIndefin logWith recorder Info $ NoConfigPath searchDirs pure emptyConfig ConfigParseError f err -> do - lift $ sendNotification SMethod_WindowShowMessage $ + lift $ pluginSendNotification SMethod_WindowShowMessage $ ShowMessageParams { _type_ = MessageType_Error , _message = errorMessage diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 933d276e48..7aefa2c524 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -32,7 +32,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 (sendRequest) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId "Provides a code action to convert datatypes to GADT syntax") @@ -70,7 +69,7 @@ toGADTCommand pId@(PluginId pId') state _ ToGADTParams{..} = withExceptT handleG pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] - _ <- lift $ sendRequest + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) (\_ -> pure ()) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index f88ff77f2d..97b9cabcae 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -108,7 +108,6 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null) import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.Server (getVersionedTextDoc) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), @@ -367,7 +366,7 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context | let TextDocumentIdentifier uri = documentId , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = do - verTxtDocId <- lift $ getVersionedTextDoc documentId + verTxtDocId <- lift $ pluginGetVersionedTextDoc documentId liftIO $ fmap (InL . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index b185240ade..4fbe89306a 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -57,7 +57,6 @@ import Ide.PluginUtils (toAbsolute) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server import Language.LSP.VFS (virtualFileText) import System.FilePath (dropExtension, isAbsolute, normalise, @@ -96,7 +95,7 @@ command recorder state _ uri = do -- | Convert an Action to the corresponding edit operation edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing in - void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) + void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) pure $ InR Null -- | A source code change @@ -109,12 +108,12 @@ data Action = Replace deriving (Show) -- | Required action (that can be converted to either CodeLenses or CodeActions) -action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (LspM c) [Action] +action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (HandlerM c) [Action] action recorder state uri = do nfp <- getNormalizedFilePathE uri fp <- uriToFilePathE uri - contents <- lift . getVirtualFile $ toNormalizedUri uri + contents <- lift . pluginGetVirtualFile $ toNormalizedUri uri let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs index e104a2146a..3d9f398ece 100644 --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -25,7 +25,6 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition), SMethod (SMethod_TextDocumentDefinition)) import Language.LSP.Protocol.Types -import qualified Language.LSP.Server as LSP import Language.LSP.VFS (VirtualFile (..)) import Text.Regex.TDFA (Regex, caseSensitive, defaultCompOpt, @@ -81,7 +80,7 @@ jumpToNote state _ param = do let Position l c = param ^. L.position contents <- fmap _file_text . err "Error getting file contents" - =<< lift (LSP.getVirtualFile uriOrig) + =<< lift (pluginGetVirtualFile uriOrig) line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents)) let noteOpt = listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs index 115fea6232..741f158eff 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -63,7 +63,7 @@ properties = -- --------------------------------------------------------------------- provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState -provider recorder plId ideState token typ contents fp _ = ExceptT $ withIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do +provider recorder plId ideState token typ contents fp _ = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do fileOpts <- maybe [] (fromDyn . hsc_dflags . hscEnv) <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp) @@ -117,7 +117,7 @@ provider recorder plId ideState token typ contents fp _ = ExceptT $ withIndefini title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) - ret :: Either SomeException T.Text -> ExceptT PluginError (LspM Types.Config) ([TextEdit] |? Null) + ret :: Either SomeException T.Text -> ExceptT PluginError (HandlerM Types.Config) ([TextEdit] |? Null) ret (Left err) = throwError $ PluginInternalError . T.pack $ "ormoluCmd: " ++ show err ret (Right new) = pure $ InL $ makeDiffTextEdit contents new diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index b43dfd928d..1f218fb1df 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -37,7 +37,6 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Server as LSP import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- @@ -199,7 +198,7 @@ completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument position@(Position ln col) = complParams ^. L.position - contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri + contents <- lift $ pluginGetVirtualFile $ toNormalizedUri uri fmap LSP.InL $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> pure $ result $ getCompletionPrefix position cnts diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 5c25c5f960..0916f9c958 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -99,7 +99,6 @@ import Language.LSP.Protocol.Types (ApplyWorkspa WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InL, InR), uriToFilePath) -import qualified Language.LSP.Server as LSP import Language.LSP.VFS (virtualFileText) import qualified Text.Fuzzy.Parallel as TFP import qualified Text.Regex.Applicative as RE @@ -110,7 +109,7 @@ import Text.Regex.TDFA ((=~), (=~~)) -- | Generate code actions. codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do - contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri + contents <- lift $ pluginGetVirtualFile $ toNormalizedUri uri liftIO $ do let text = virtualFileText <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri @@ -190,7 +189,7 @@ extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do whenJust (listToMaybe =<< listToMaybe . M.elems =<< _changes) $ \TextEdit {_range} -> do let srcSpan = rangeToSrcSpan nfp _range - LSP.sendNotification SMethod_WindowShowMessage $ + pluginSendNotification SMethod_WindowShowMessage $ ShowMessageParams MessageType_Info $ "Import " <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent @@ -199,7 +198,7 @@ extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do <> " (at " <> printOutputable srcSpan <> ")" - void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + void $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right $ InR Null extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 7601b4f9e7..7eed2e1130 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -41,7 +41,6 @@ import Ide.Plugin.Error (PluginError) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Server as LSP type CodeActionTitle = T.Text @@ -53,7 +52,7 @@ type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCo ------------------------------------------------------------------------------------------------- -runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult +runGhcideCodeAction :: IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> HandlerM Config GhcideCodeActionResult runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index c6452441f2..7d415fb092 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -49,7 +49,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 instance Hashable (Mod a) where hash n = hash (unMod n) @@ -110,19 +109,18 @@ renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) p let newName = mkTcOcc $ T.unpack newNameText filesRefs = collectWith locToUri refs getFileEdit (uri, locations) = do - verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri) + verTxtDocId <- lift $ pluginGetVersionedTextDoc (TextDocumentIdentifier uri) getSrcEdit state verTxtDocId (replaceRefs newName locations) fileEdits <- mapM getFileEdit filesRefs pure $ InL $ fold fileEdits -- | Limit renaming across modules. failWhenImportOrExport :: - (MonadLsp config m) => IdeState -> NormalizedFilePath -> HashSet Location -> [Name] -> - ExceptT PluginError m () + ExceptT PluginError (HandlerM config) () failWhenImportOrExport state nfp refLocs names = do pm <- runActionE "Rename.GetParsedModule" state (useE GetParsedModule nfp) @@ -140,13 +138,12 @@ failWhenImportOrExport state nfp refLocs names = do -- | Apply a function to a `ParsedSource` for a given `Uri` to compute a `WorkspaceEdit`. getSrcEdit :: - (MonadLsp config m) => IdeState -> VersionedTextDocumentIdentifier -> (ParsedSource -> ParsedSource) -> - ExceptT PluginError m WorkspaceEdit + ExceptT PluginError (HandlerM config) WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do - ccs <- lift getClientCapabilities + ccs <- lift pluginGetClientCapabilities nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) annAst <- runActionE "Rename.GetAnnotatedParsedSource" state (useE GetAnnotatedParsedSource nfp) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 34fec3a4a4..15fc8fb097 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -98,10 +98,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types as LSP -import Language.LSP.Server (ProgressCancellable (Cancellable), - sendNotification, - sendRequest, - withIndefiniteProgress) +import Language.LSP.Server (ProgressCancellable (Cancellable)) import Retrie (Annotated (astA), AnnotatedModule, Fixity (Fixity), @@ -174,7 +171,7 @@ data RunRetrieParams = RunRetrieParams runRetrieCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState RunRetrieParams runRetrieCmd recorder state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ - withIndefiniteProgress description token Cancellable $ \_updater -> do + pluginWithIndefiniteProgress description token Cancellable $ \_updater -> do _ <- runExceptT $ do nfp <- getNormalizedFilePathE uri (session, _) <- @@ -192,12 +189,12 @@ runRetrieCmd recorder state token RunRetrieParams{originatingFile = uri, ..} = E nfp restrictToOriginatingFile unless (null errors) $ - lift $ sendNotification SMethod_WindowShowMessage $ + lift $ pluginSendNotification SMethod_WindowShowMessage $ ShowMessageParams MessageType_Warning $ T.unlines $ "## Found errors during rewrite:" : ["-" <> T.pack (show e) | e <- errors] - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) return () return $ Right $ InR Null @@ -238,7 +235,7 @@ runRetrieInlineThisCmd recorder state _token RunRetrieInlineThisParams{..} = do ourReplacement = [ r | r@Replacement{..} <- replacements , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation] - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ InR Null diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index a756fd301e..9ec6ea8c2d 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -5,69 +5,73 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Splice ( descriptor, ) where -import Control.Applicative (Alternative ((<|>))) -import Control.Arrow ( Arrow(first) ) -import Control.Exception ( SomeException ) -import qualified Control.Foldl as L -import Control.Lens (Identity (..), ix, view, (%~), - (<&>), (^.)) -import Control.Monad ( guard, unless, forM ) -import Control.Monad.Error.Class ( MonadError(throwError) ) -import Control.Monad.Extra (eitherM) -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Unlift ( MonadIO(..), askRunInIO ) -import Control.Monad.Trans.Class ( MonadTrans(lift) ) -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT ) +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (Arrow (first)) +import Control.Exception (SomeException) +import qualified Control.Foldl as L +import Control.Lens (Identity (..), ix, + view, (%~), (<&>), + (^.)) +import Control.Monad (forM, guard, unless) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Extra (eitherM) +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Unlift (MonadIO (..), + askRunInIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) import Control.Monad.Trans.Maybe -import Data.Aeson hiding (Null) -import qualified Data.Bifunctor as B (first) -import Data.Foldable (Foldable (foldl')) +import Data.Aeson hiding (Null) +import qualified Data.Bifunctor as B (first) +import Data.Foldable (Foldable (foldl')) import Data.Function import Data.Generics -import qualified Data.Kind as Kinds -import Data.List (sortOn) -import Data.Maybe (fromMaybe, listToMaybe, - mapMaybe) -import qualified Data.Text as T +import qualified Data.Kind as Kinds +import Data.List (sortOn) +import Data.Maybe (fromMaybe, + listToMaybe, + mapMaybe) +import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PluginUtils -import Development.IDE.GHC.Compat as Compat hiding (getLoc) +import Development.IDE.GHC.Compat as Compat hiding + (getLoc) import Development.IDE.GHC.Compat.ExactPrint -import qualified Development.IDE.GHC.Compat.Util as Util +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Transform (TransformT(TransformT)) +import Language.Haskell.GHC.ExactPrint.Transform (TransformT (TransformT)) #if MIN_VERSION_ghc(9,4,1) -import GHC.Data.Bag (Bag) +import GHC.Data.Bag (Bag) #endif import GHC.Exts -import GHC.Parser.Annotation (SrcSpanAnn'(..)) -import qualified GHC.Types.Error as Error +import GHC.Parser.Annotation (SrcSpanAnn' (..)) +import qualified GHC.Types.Error as Error +import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.Plugin.Splice.Types import Ide.Types -import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) -import Language.LSP.Server -import Language.LSP.Protocol.Types +import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) +import qualified Language.LSP.Protocol.Lens as J import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Lens as J -import Ide.Plugin.Error (PluginError(PluginInternalError)) +import Language.LSP.Protocol.Types descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -95,10 +99,10 @@ expandTHSplice :: ExpandStyle -> CommandFunction IdeState ExpandSpliceParams expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do - clientCapabilities <- getClientCapabilities + clientCapabilities <- pluginGetClientCapabilities rio <- askRunInIO let reportEditor :: ReportEditor - reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + reportEditor msgTy msgs = liftIO $ rio $ pluginSendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit expandManually fp = do mresl <- @@ -195,7 +199,7 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do Nothing -> pure $ Right $ InR Null Just (Left err) -> pure $ Left $ err Just (Right edit) -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + _ <- pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure $ Right $ InR Null where @@ -245,7 +249,7 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) = let minStart = case L.fold (L.premap (view J.range) L.minimum) eds of Nothing -> error "impossible" - Just v -> v + Just v -> v in adjustLine minStart <$> eds adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit) @@ -305,7 +309,7 @@ instance HasSplice AnnListItem HsExpr where #if MIN_VERSION_ghc(9,5,0) type SpliceOf HsExpr = HsSpliceCompat matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl) - matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl) + matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl) #else type SpliceOf HsExpr = HsSplice matchSplice _ (HsSpliceE _ spl) = Just spl @@ -394,7 +398,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e (fst <$> expandSplice astP spl) ) Just <$> case eExpr of - Left x -> pure $ L _spn x + Left x -> pure $ L _spn x Right y -> unRenamedE dflags y _ -> pure Nothing let (warns, errs) = @@ -471,7 +475,7 @@ fromSearchResult _ = Nothing -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction state plId (CodeActionParams _ _ docId ran _) = do - verTxtDocId <- lift $ getVersionedTextDoc docId + verTxtDocId <- lift $ pluginGetVersionedTextDoc docId liftIO $ fmap (fromMaybe ( InL [])) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri @@ -506,12 +510,12 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = do | spanIsRelevant l -> case expr of #if MIN_VERSION_ghc(9,5,0) - HsTypedSplice{} -> Here (spLoc, Expr) + HsTypedSplice{} -> Here (spLoc, Expr) HsUntypedSplice{} -> Here (spLoc, Expr) #else - HsSpliceE {} -> Here (spLoc, Expr) + HsSpliceE {} -> Here (spLoc, Expr) #endif - _ -> Continue + _ -> Continue _ -> Stop ) `extQ` \case