diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index c134a26045..5f3ca5882f 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -51,15 +51,19 @@ import UnliftIO.Exception (catchAny) -- data Log - = LogPluginError PluginId ResponseError + = LogPluginError PluginId ResponseError | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier + | ExceptionInPlugin PluginId (Some SMethod) SomeException + instance Pretty Log where pretty = \case LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" + ExceptionInPlugin plId (Some method) exception -> + "Exception in plugin " <> viaShow plId <> " while processing "<> viaShow method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty @@ -92,6 +96,10 @@ failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> ", arg = " <> T.pack (show arg) +exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text +exceptionInPlugin plId method exception = + "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception) + -- | Build a ResponseError and log it before returning to the caller logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder p errCode msg = do @@ -99,6 +107,13 @@ logAndReturnError recorder p errCode msg = do logWith recorder Warning $ LogPluginError p err pure $ Left err +-- | Logs the provider error before returning it to the caller +logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError' recorder errCode msg = do + let err = ResponseError errCode (fromString $ show msg) Nothing + logWith recorder Warning $ msg + pure $ Left err + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = @@ -177,9 +192,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- If we have a command, continue to execute it Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right $ InL A.Null + Nothing -> return $ Right $ InR Null - A.Error _str -> return $ Right $ InL A.Null + A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams @@ -197,7 +212,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs) 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 -> fmap InL <$> f ide a + A.Success a -> + f ide a `catchAny` -- See Note [Exception handling in plugins] + (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) -- --------------------------------------------------------------------- @@ -225,9 +242,8 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } msg = pluginNotEnabled m fs' return $ Left err Just fs -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs - es <- runConcurrently msg (show m) handlers ide params + let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs + es <- runConcurrently exceptionInPlugin m handlers ide params let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es unless (null errs) $ forM_ errs $ \(pId, err) -> @@ -261,22 +277,25 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs + mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params + `catchAny` -- See Note [Exception handling in plugins] + (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs + -- --------------------------------------------------------------------- runConcurrently :: MonadUnliftIO m - => (SomeException -> PluginId -> T.Text) - -> String -- ^ label + => (PluginId -> SMethod method -> SomeException -> T.Text) + -> SMethod method -- ^ Method (used for errors and tracing) -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) -- ^ Enabled plugin actions that we are allowed to run -> a -> b -> m (NonEmpty(NonEmpty (Either ResponseError d))) -runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do - f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg e pid) Nothing) +runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do + f a b -- See Note [Exception handling in plugins] + `catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg pid method e) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x @@ -308,3 +327,16 @@ instance Semigroup IdeNotificationHandlers where go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b) instance Monoid IdeNotificationHandlers where mempty = IdeNotificationHandlers mempty + +{- Note [Exception handling in plugins] +Plugins run in LspM, and so have access to IO. This means they are likely to +throw exceptions, even if only by accident or through calling libraries that +throw exceptions. Ultimately, we're running a bunch of less-trusted IO code, +so we should be robust to it throwing. + +We don't want these to bring down HLS. So we catch and log exceptions wherever +we run a handler defined in a plugin. + +The flip side of this is that it's okay for plugins to throw exceptions as a +way of signalling failure! +-} diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 8d403ce8ab..6028d29132 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -16,8 +16,9 @@ import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM -import Data.Aeson -import Data.Aeson.Types +import Data.Aeson (FromJSON (parseJSON), + ToJSON (toJSON), Value) +import qualified Data.Aeson.Types as A import Data.Bifunctor import Data.CaseInsensitive (CI, original) import qualified Data.HashMap.Strict as HM @@ -46,7 +47,7 @@ import GHC.Generics (Generic) import Ide.Plugin.Config (CheckParents) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import qualified "list-t" ListT import qualified StmContainers.Map as STM @@ -80,7 +81,7 @@ plugin = (defaultPluginDescriptor "test") { } where testRequestHandler' ide req - | Just customReq <- parseMaybe parseJSON req + | Just customReq <- A.parseMaybe parseJSON req = testRequestHandler ide customReq | otherwise = return $ Left @@ -94,7 +95,7 @@ testRequestHandler _ (BlockSeconds secs) = do LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs liftIO $ sleep secs - return (Right Null) + return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp @@ -107,7 +108,7 @@ testRequestHandler s WaitForShakeQueue = liftIO $ do atomically $ do n <- countQueue $ actionQueue $ shakeExtras s when (n>0) retry - return $ Right Null + return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp @@ -172,6 +173,6 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId) { blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _params = do - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) Null + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null liftIO $ threadDelay maxBound - return (Right Null) + return (Right $ InR Null) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 791d29c5c5..0056fb0f7b 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -18,7 +18,7 @@ import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson.Types (Value (..), toJSON) +import Data.Aeson.Types (Value, toJSON) import qualified Data.Aeson.Types as A import Data.List (find) import qualified Data.Map as Map @@ -69,10 +69,11 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), + Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), - type (|?) (InL)) + type (|?) (..)) import qualified Language.LSP.Server as LSP import Text.Regex.TDFA ((=~), (=~~)) @@ -161,7 +162,7 @@ generateLens pId _range title edit = commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + return $ Right $ InR Null -------------------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index b7aaa6e231..245322b224 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -873,7 +873,7 @@ data PluginCommand ideState = forall a. (FromJSON a) => type CommandFunction ideState a = ideState -> a - -> LspM Config (Either ResponseError Value) + -> LspM Config (Either ResponseError (Value |? Null)) -- --------------------------------------------------------------------- @@ -1093,7 +1093,7 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = case resolveResult of Right CodeAction {_edit = Just wedits } -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right Data.Aeson.Null + pure $ Right $ InR Null Right _ -> pure $ Left $ responseError "No edit in CodeAction" Left err -> pure $ Left err 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 3f125ab746..05134c88a6 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -12,7 +12,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, throwE) import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Bifunctor (second) import Data.Either.Extra (rights) import Data.List @@ -37,7 +37,7 @@ import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams @@ -64,7 +64,7 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure Null + pure $ InR Null where toTextDocumentEdit edit = TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit] 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 fe8af4b812..462a3af234 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -7,7 +7,7 @@ module Ide.Plugin.Class.CodeLens where import Control.Lens ((^.)) import Control.Monad.IO.Class (liftIO) -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Text as T import Development.IDE @@ -21,7 +21,7 @@ import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens @@ -143,4 +143,4 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit codeLensCommandHandler _ wedit = do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + return $ Right $ InR Null 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 f8e44fa19e..c4f0847f5b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -18,7 +18,7 @@ import Control.Exception (SomeException, evaluate, import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Aeson (Value (Null)) +import Data.Aeson (Value) import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), @@ -32,7 +32,7 @@ import GHC.Stack (HasCallStack, callStack, srcLocStartCol, srcLocStartLine) import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server import System.FilePath (takeExtension) import System.Time.Extra (duration, showDuration) @@ -66,7 +66,7 @@ logLevel = Debug -- Info isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) +response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError (Value |? Null)) response' act = do res <- runExceptT act `catchAny` showErr @@ -75,7 +75,7 @@ response' act = do return $ Left (ResponseError (InR ErrorCodes_InternalError) (fromString e) Nothing) Right a -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) - return $ Right Null + return $ Right $ InR Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = 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 741d3a87c3..0a929bf4f3 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -21,7 +21,7 @@ module Ide.Plugin.ExplicitImports import Control.DeepSeq import Control.Monad.IO.Class import Data.Aeson (ToJSON (toJSON), - Value (Null)) + Value ()) import Data.Aeson.Types (FromJSON) import qualified Data.HashMap.Strict as HashMap import Data.IORef (readIORef) @@ -41,7 +41,7 @@ import GHC.Generics (Generic) import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server importCommandId :: CommandId @@ -97,7 +97,7 @@ runImportCommand :: CommandFunction IdeState ImportCommandParams runImportCommand _state (ImportCommandParams edit) = do -- This command simply triggers a workspace edit! _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right Null) + return (Right $ InR Null) -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 93c1805d82..fcd5d8ebef 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -12,8 +12,7 @@ import Control.Lens ((^.)) import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Data.Aeson (FromJSON, ToJSON, Value (Null), - toJSON) +import Data.Aeson (FromJSON, ToJSON, Value, toJSON) import Data.Either.Extra (maybeToEither) import qualified Data.Map as Map import qualified Data.Text as T @@ -29,7 +28,7 @@ import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server (sendRequest) descriptor :: PluginId -> PluginDescriptor IdeState @@ -72,7 +71,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) (\_ -> pure ()) - pure Null + pure $ InR Null where workSpaceEdit nfp edits = WorkspaceEdit (pure $ Map.fromList 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 f9336920da..eab0c67a9c 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -21,7 +21,7 @@ import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe -import Data.Aeson (Value (Null), toJSON) +import Data.Aeson (Value, toJSON) import Data.Char (isLower) import Data.List (intercalate, isPrefixOf, minimumBy) @@ -54,7 +54,7 @@ import Development.IDE.GHC.Compat (GenLocated (L), import Development.IDE.Types.Logger (Pretty (..)) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) import System.Directory (makeAbsolute) @@ -94,7 +94,7 @@ command recorder state uri = do edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing in void $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) - pure $ Right Null + pure $ Right $ InR Null -- | A source code change data Action = Replace 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 97fdd80e70..727a959620 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -22,7 +22,6 @@ import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe -import Data.Aeson as A import Data.Char import qualified Data.DList as DL import Data.Function @@ -85,7 +84,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspa Command, Diagnostic (..), MessageType (..), - Null, + Null (Null), ShowMessageParams (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit, _range), @@ -212,7 +211,7 @@ extendImportHandler ideState edit@ExtendImport {..} = do <> printOutputable srcSpan <> ")" void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right A.Null + return $ Right $ InR Null extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) extendImportHandler' ideState ExtendImport {..} diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 42a401e2ad..39616221bb 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -15,7 +15,7 @@ import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) import Control.Monad (join) import Control.Monad.IO.Class (liftIO) -import Data.Aeson.Types +import Data.Aeson.Types hiding (Null) import Data.IORef (readIORef) import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -57,7 +57,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEd TextEdit (..), WorkspaceEdit (..), type (|?) (InL, InR), - uriToNormalizedFilePath) + uriToNormalizedFilePath, Null (Null)) import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction, Method_TextDocumentCodeLens), SMethod (SMethod_TextDocumentCodeAction, SMethod_TextDocumentCodeLens, SMethod_WorkspaceApplyEdit),) newtype Log = LogShake Shake.Log deriving Show @@ -100,7 +100,7 @@ runRefineImportCommand :: CommandFunction IdeState RefineImportCommandParams runRefineImportCommand _state (RefineImportCommandParams edit) = do -- This command simply triggers a workspace edit! _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right Null) + return (Right $ InR Null) lensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens lensProvider diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 990e261762..f517e75315 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -33,8 +33,7 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT), import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Strict import Data.Aeson (FromJSON (..), - ToJSON (..), - Value (Null)) + ToJSON (..), Value) import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Coerce @@ -118,7 +117,7 @@ import Ide.PluginUtils 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 hiding (Null) +import Language.LSP.Protocol.Types as LSP import Language.LSP.Server (LspM, ProgressCancellable (Cancellable), sendNotification, @@ -209,7 +208,7 @@ data RunRetrieParams = RunRetrieParams runRetrieCmd :: IdeState -> RunRetrieParams -> - LspM c (Either ResponseError Value) + LspM c (Either ResponseError (Value |? Null)) runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = withIndefiniteProgress description Cancellable $ do runMaybeT $ do @@ -236,7 +235,7 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = ["-" <> T.pack (show e) | e <- errors] lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) return () - return $ Right Null + return $ Right $ InR Null data RunRetrieInlineThisParams = RunRetrieInlineThisParams { inlineIntoThisLocation :: !Location, @@ -246,7 +245,7 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams deriving (Eq, Show, Generic, FromJSON, ToJSON) runRetrieInlineThisCmd :: IdeState - -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value) + -> RunRetrieInlineThisParams -> LspM c (Either ResponseError (Value |? Null)) runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do nfp <- handleMaybe "uri" $ uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineIntoThisLocation nfpSource <- handleMaybe "sourceUri" $ @@ -287,7 +286,7 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation] lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return Null + return $ InR Null -- Override to skip adding binders to the context, which prevents inlining -- nested defined functions diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 0cf5da4541..d4af48ddbc 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -37,7 +37,7 @@ import Control.Monad.IO.Unlift import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Foldable (Foldable (foldl')) import Data.Function import Data.Generics @@ -64,7 +64,7 @@ import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) import Language.LSP.Server -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Lens as J @@ -192,11 +192,11 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do Right edits -> pure (Right edits) case res of - Nothing -> pure $ Right Null + Nothing -> pure $ Right $ InR Null Just (Left err) -> pure $ Left err Just (Right edit) -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure $ Right Null + pure $ Right $ InR Null where range = realSrcSpanToRange spliceSpan diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index c9c8e50fe3..e31a2f6cd8 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -103,7 +103,7 @@ runContinuation plId cont state (fc, b) = do res <- c_runCommand cont env args fc b -- This block returns a maybe error. - fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $ + fmap (maybe (Right $ InR Null) Left . coerce . foldMap Last) $ for res $ \case ErrorMessages errs -> do traverse_ showUserFacingMessage errs