Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Catch exceptions in commands and use lsp null #3696

Merged
merged 6 commits into from
Jul 11, 2023
Merged

Catch exceptions in commands and use lsp null #3696

Show file tree
Hide file tree
Changes from 3 commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
a774ba9
Catch exceptions in commands and use lsp null
joyfulmantis Jul 8, 2023
d511957
Catch and log errors in notification handlers
joyfulmantis Jul 8, 2023
0425469
more lsp null fixes
joyfulmantis Jul 8, 2023
28f2e6c
Update HLS.hs
joyfulmantis Jul 10, 2023
e6f408c
Added michealpj's note
joyfulmantis Jul 10, 2023
bcd8538
Merge branch 'master' into command-fixes
joyfulmantis Jul 10, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
42 changes: 30 additions & 12 deletions ghcide/src/Development/IDE/Plugin/HLS.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -51,15 +51,18 @@ 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

Expand Down Expand Up @@ -92,13 +95,24 @@ 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
let err = ResponseError errCode msg Nothing
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) =
Expand Down Expand Up @@ -177,9 +191,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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is fine but I it's literally the same behaviour. The upstream spec is weird, I made an issue: microsoft/language-server-protocol#1766


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
Expand All @@ -197,7 +211,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`
(\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e))
fendor marked this conversation as resolved.
Show resolved Hide resolved

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -225,9 +241,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) ->
Expand Down Expand Up @@ -261,22 +276,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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

🙈

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`
(\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs
fendor marked this conversation as resolved.
Show resolved Hide resolved


-- ---------------------------------------------------------------------

runConcurrently
:: MonadUnliftIO m
=> (SomeException -> PluginId -> T.Text)
-> String -- ^ label
=> (PluginId -> SMethod method -> SomeException -> T.Text)
-> SMethod method -- ^ label
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

wrong comment

-> 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
runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do
f a b
`catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg e pid) Nothing)
`catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg pid method e) Nothing)

combineErrors :: [ResponseError] -> ResponseError
combineErrors [x] = x
Expand Down
17 changes: 9 additions & 8 deletions ghcide/src/Development/IDE/Plugin/Test.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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)
7 changes: 4 additions & 3 deletions ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 ((=~), (=~~))

Expand Down Expand Up @@ -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

--------------------------------------------------------------------------------

Expand Down
4 changes: 2 additions & 2 deletions hls-plugin-api/src/Ide/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

tbh, since they're represented the same, I'm not sure this really adds much except making things more complex for the users

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would say less complex. LSP Types are used everywhere, and now command users don't need to use Aeson if they don't use it anywhere else (Pretty much every command returns null).

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It doesn't matter too much, but I would hope that we can fix this upstream, and then we'd have to go back again...

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Good point. Is there any reason why we can't use Aeson.Null for Null in lsp-types, perhaps by reexporting it instead of declaring our own? that would remove a source of name conflicts.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Okay right, because it's only a constructor, not a type in its own right.


-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -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

Expand Down
6 changes: 3 additions & 3 deletions plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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]
Expand Down
6 changes: 3 additions & 3 deletions plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
8 changes: 4 additions & 4 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..),
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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 =
Expand Down
6 changes: 3 additions & 3 deletions plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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:
Expand Down
7 changes: 3 additions & 4 deletions plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
Loading