From 0c07da6478ebdfe7ad294e7545f19f4d38a7049a Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Mon, 23 May 2022 11:24:01 -0400 Subject: [PATCH 01/10] Log ResponseErrors when returned from Plugins --- ghcide/src/Development/IDE/Plugin/HLS.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 7c8c7cec68..4d210e5d33 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -10,6 +10,7 @@ module Development.IDE.Plugin.HLS ) where import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad import qualified Data.Aeson as J import Data.Bifunctor @@ -21,6 +22,7 @@ import qualified Data.List as List import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map import Data.String +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing @@ -33,9 +35,10 @@ import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS import qualified Language.LSP.Server as LSP -import Language.LSP.VFS import Language.LSP.Types import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.VFS import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) @@ -46,19 +49,22 @@ import UnliftIO.Exception (catchAny) data Log = LogNoEnabledPlugins + | LogPluginError ResponseError deriving Show instance Pretty Log where pretty = \case LogNoEnabledPlugins -> "extensibleNotificationPlugins no enabled plugins" + LogPluginError err -> pretty (err ^. LSP.message) + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> - mkPlugin extensiblePlugins HLS.pluginHandlers <> + mkPlugin (extensiblePlugins recorder) HLS.pluginHandlers <> mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where @@ -153,8 +159,8 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config -extensiblePlugins xs = mempty { P.pluginHandlers = handlers } +extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginHandlers IdeState)] -> Plugin Config +extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers @@ -174,11 +180,13 @@ extensiblePlugins xs = mempty { P.pluginHandlers = handlers } let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) es <- runConcurrently msg (show m) fs ide params let (errs,succs) = partitionEithers $ toList es + unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err case nonEmpty succs of Nothing -> pure $ Left $ combineErrors errs Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs + -- --------------------------------------------------------------------- extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config From e274527136d88736107f3e50a4388375cabb154a Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Sat, 28 May 2022 13:34:32 -0400 Subject: [PATCH 02/10] Log from Plugins --- ghcide/src/Development/IDE/Plugin/HLS.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 4d210e5d33..aec30d3173 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -49,14 +49,14 @@ import UnliftIO.Exception (catchAny) data Log = LogNoEnabledPlugins - | LogPluginError ResponseError + | LogPluginError PluginId ResponseError deriving Show instance Pretty Log where pretty = \case LogNoEnabledPlugins -> "extensibleNotificationPlugins no enabled plugins" - LogPluginError err -> pretty (err ^. LSP.message) + LogPluginError plid err -> pretty (err ^. LSP.message) -- | Map a set of plugins to the underlying ghcide engine. @@ -180,9 +180,9 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) es <- runConcurrently msg (show m) fs ide params let (errs,succs) = partitionEithers $ toList es - unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err + unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ uncurry LogPluginError err case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors errs + Nothing -> pure $ Left $ combineErrors (map snd errs) Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs @@ -220,10 +220,11 @@ runConcurrently -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) -> a -> b - -> m (NonEmpty (Either ResponseError d)) + -> m (NonEmpty (Either (PluginId, ResponseError) d)) runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do - f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + -- attach the PluginId on ResponseError for logging purposes + fmap (first (pid,)) <$> (f a b + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x From 7f45bd085ce90996b05b5a932f3f901e47f8b084 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Wed, 22 Jun 2022 23:26:57 -0400 Subject: [PATCH 03/10] Create 'logAndReturnError' that will log any failures in plugins --- ghcide/src/Development/IDE/Plugin/HLS.hs | 87 ++++++++++++++---------- 1 file changed, 52 insertions(+), 35 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index aec30d3173..1d7041e74a 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -47,23 +47,47 @@ import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- -data Log - = LogNoEnabledPlugins - | LogPluginError PluginId ResponseError - deriving Show +data Log = LogPluginError ResponseError + deriving Show instance Pretty Log where pretty = \case - LogNoEnabledPlugins -> - "extensibleNotificationPlugins no enabled plugins" - LogPluginError plid err -> pretty (err ^. LSP.message) + LogPluginError err -> responseErrorToLogMessage err +responseErrorToLogMessage :: ResponseError -> Doc a +responseErrorToLogMessage err = errorCode <> ":" <+> errorBody + where + errorCode = pretty $ show $ err ^. LSP.code + errorBody = pretty $ err ^. LSP.message + +pluginNotEnabled :: SMethod m -> Text +pluginNotEnabled method = "No plugin enabled for " <> T.pack (show method) + +pluginDoesntExist :: PluginId -> Text +pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" + +commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text +commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are: " <> T.pack (show $ map commandId legalCmds) + +failedToParseArgs :: CommandId -- ^ command that failed to parse + -> PluginId -- ^ Plugin that created the command + -> String -- ^ The JSON Error message + -> J.Value -- ^ The Argument Values + -> Text +failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> "\narg = " <> T.pack (show arg) + +-- | Build a ResponseError and log it before returning to the caller +logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError J.Value) +logAndReturnError recorder errCode msg = do + let err = ResponseError errCode msg Nothing + logWith recorder Warning $ LogPluginError err + 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) = mkPlugin rulesPlugins HLS.pluginRules <> - mkPlugin executeCommandPlugins HLS.pluginCommands <> + mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <> mkPlugin (extensiblePlugins recorder) HLS.pluginHandlers <> mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags @@ -97,11 +121,11 @@ dynFlagsPlugins rs = mempty -- --------------------------------------------------------------------- -executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config -executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs } +executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> Plugin Config +executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd +executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) +executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd where pluginMap = Map.fromList ecs @@ -140,21 +164,15 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams -- Couldn't parse the command identifier - _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + _ -> logAndReturnError recorder InvalidParams "Invalid command Identifier" - runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = + runPluginCommand ide p com arg = case Map.lookup p pluginMap of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) + Nothing -> logAndReturnError recorder InvalidRequest (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return $ Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing + Nothing -> logAndReturnError recorder InvalidRequest (commandDoesntExist com p xs) Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return $ Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing + J.Error err -> logAndReturnError recorder InvalidParams (failedToParseArgs com p err arg) J.Success a -> f ide a -- --------------------------------------------------------------------- @@ -172,17 +190,19 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } pure $ requestHandler m $ \ide params -> do config <- Ide.PluginUtils.getClientConfig let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' + -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> pure $ Left $ ResponseError InvalidRequest - ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs)) - Nothing + Nothing -> do + let err = ResponseError InvalidRequest (pluginNotEnabled m) Nothing + logWith recorder Info $ LogPluginError err + pure $ 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) es <- runConcurrently msg (show m) fs ide params let (errs,succs) = partitionEithers $ toList es - unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ uncurry LogPluginError err + unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors (map snd errs) + Nothing -> pure $ Left $ combineErrors errs Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs @@ -203,9 +223,7 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers config <- Ide.PluginUtils.getClientConfig let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' case nonEmpty fs of - Nothing -> do - logWith recorder Info LogNoEnabledPlugins - pure () + Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m) Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last @@ -220,11 +238,10 @@ runConcurrently -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) -> a -> b - -> m (NonEmpty (Either (PluginId, ResponseError) d)) + -> m (NonEmpty (Either ResponseError d)) runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do - -- attach the PluginId on ResponseError for logging purposes - fmap (first (pid,)) <$> (f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)) + f a b + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x From c857168734b8c4ad4be27dec8d11349f886df8e0 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Wed, 22 Jun 2022 23:31:56 -0400 Subject: [PATCH 04/10] Missed opportunity to use logAndReturnError --- ghcide/src/Development/IDE/Plugin/HLS.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 1d7041e74a..57702040ff 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -77,7 +77,7 @@ failedToParseArgs :: CommandId -- ^ command that failed to parse failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> "\narg = " <> T.pack (show arg) -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError J.Value) +logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder errCode msg = do let err = ResponseError errCode msg Nothing logWith recorder Warning $ LogPluginError err @@ -192,10 +192,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> do - let err = ResponseError InvalidRequest (pluginNotEnabled m) Nothing - logWith recorder Info $ LogPluginError err - pure $ Left err + Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m) Just fs -> do let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) es <- runConcurrently msg (show m) fs ide params From a4e87cb2ce8062484cab7f534ea4604dbe791c3d Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Wed, 22 Jun 2022 23:40:59 -0400 Subject: [PATCH 05/10] Revert throwPluginError to throwE This reverts a change made previously to try to make pluginErrors have a common error format. This will be updated in the near future. --- hls-plugin-api/src/Ide/PluginUtils.hs | 6 ++---- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 4 ++-- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 19303516ac..c5bb881b58 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -253,10 +253,8 @@ getNormalizedFilePath (PluginId plId) uri = handleMaybe errMsg errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri <> " to NormalizedFilePath" -- --------------------------------------------------------------------- -throwPluginError :: Monad m => PluginId -> String -> String -> ExceptT String m b -throwPluginError (PluginId who) what where' = throwE msg - where - msg = (T.unpack who) <> " failed with " <> what <> " at " <> where' +throwPluginError :: Monad m => String -> ExceptT String m b +throwPluginError = throwE handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 0a4b1de41e..ed6ad5e534 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -203,7 +203,7 @@ incomingCalls state pluginId param = pluginResponse $ do mergeIncomingCalls case calls of Just x -> pure $ Just $ List x - Nothing -> throwPluginError callHierarchyId "Internal Error" "incomingCalls" + Nothing -> throwPluginError "incomingCalls - Internal Error" where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall @@ -224,7 +224,7 @@ outgoingCalls state pluginId param = pluginResponse $ do mergeOutgoingCalls case calls of Just x -> pure $ Just $ List x - Nothing -> throwPluginError callHierarchyId "Internal Error" "outgoingCalls" + Nothing -> throwPluginError "outgoingCalls - Internal Error" where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall From 9a92d795154d0bf1c38ca07575fe18ca02e5e0a3 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Fri, 24 Jun 2022 20:42:27 -0400 Subject: [PATCH 06/10] Warning -> Error --- ghcide/src/Development/IDE/Plugin/HLS.hs | 3 ++- .../src/Ide/Plugin/AlternateNumberFormat.hs | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 57702040ff..9931ca7f08 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -60,6 +60,7 @@ responseErrorToLogMessage err = errorCode <> ":" <+> errorBody errorCode = pretty $ show $ err ^. LSP.code errorBody = pretty $ err ^. LSP.message +-- various error message specific builders pluginNotEnabled :: SMethod m -> Text pluginNotEnabled method = "No plugin enabled for " <> T.pack (show method) @@ -80,7 +81,7 @@ failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder errCode msg = do let err = ResponseError errCode msg Nothing - logWith recorder Warning $ LogPluginError err + logWith recorder Error $ LogPluginError err pure $ Left err -- | Map a set of plugins to the underlying ghcide engine. diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index e240ee297d..530ced8f7a 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -97,7 +97,6 @@ codeActionHandler state plId (CodeActionParams _ _ docId currRange _) = pluginRe literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange -- make a code action for every literal and its' alternates (then flatten the result) actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs - pure $ List actions where inCurrentRange :: Literal -> Bool From f886d63f5e355bde99596130fbe92197dbba931b Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Sat, 25 Jun 2022 15:14:06 -0400 Subject: [PATCH 07/10] Fix Functional Test for Plugin Response Error --- test/functional/Format.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 43e9366843..1d08d93f9c 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -47,7 +47,7 @@ providerTests = testGroup "formatting provider" [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: []" Nothing) + liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: [PluginId \"floskell\",PluginId \"fourmolu\",PluginId \"ormolu\",PluginId \"stylish-haskell\",PluginId \"brittany\"]" Nothing) , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" From c14a9203c2226a3625e4e956d94ef532fad99fe8 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Tue, 28 Jun 2022 07:58:37 -0400 Subject: [PATCH 08/10] Add orphan instances for --- ghcide/src/Development/IDE/Plugin/HLS.hs | 14 +-- ghcide/src/Development/IDE/Types/Logger.hs | 102 +++++++++++++-------- 2 files changed, 69 insertions(+), 47 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 66da4702d7..b5d2ef6114 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -52,23 +52,17 @@ data Log = LogPluginError ResponseError instance Pretty Log where pretty = \case - LogPluginError err -> responseErrorToLogMessage err - -responseErrorToLogMessage :: ResponseError -> Doc a -responseErrorToLogMessage err = errorCode <> ":" <+> errorBody - where - errorCode = pretty $ show $ err ^. LSP.code - errorBody = pretty $ err ^. LSP.message + LogPluginError err -> pretty err -- various error message specific builders pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text -pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available: " <> T.pack (show $ map (\(plid,_,_) -> plid) availPlugins) +pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available:\n" <> T.pack (unlines $ map (\(plid,_,_) -> show plid) availPlugins) pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text -commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are: " <> T.pack (show $ map commandId legalCmds) +commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are:\n" <> T.pack (unlines $ map (show . commandId) legalCmds) failedToParseArgs :: CommandId -- ^ command that failed to parse -> PluginId -- ^ Plugin that created the command @@ -202,7 +196,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs es <- runConcurrently msg (show m) handlers ide params let (errs,succs) = partitionEithers $ toList es - unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err + unless (null errs) $ forM_ errs $ \err -> logWith recorder Error $ LogPluginError err case nonEmpty succs of Nothing -> pure $ Left $ combineErrors errs Just xs -> do diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index a858a5f520..bb0df3d7df 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -29,48 +29,63 @@ module Development.IDE.Types.Logger , renderStrict ) where -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Concurrent.STM (atomically, - newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue) -import Control.Exception (IOException) -import Control.Monad (forM_, when, (>=>), unless) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Foldable (for_) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, formatTime, - getCurrentTime) -import GHC.Stack (CallStack, HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), - callStack, getCallStack, - withFrozenCallStack) +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Concurrent.STM (atomically, + flushTBQueue, + isFullTBQueue, + newTBQueueIO, newTVarIO, + readTVarIO, + writeTBQueue, writeTVar) +import Control.Exception (IOException) +import Control.Monad (forM_, unless, when, + (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Foldable (for_) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, + formatTime, + getCurrentTime) +import GHC.Stack (CallStack, HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), + callStack, getCallStack, + withFrozenCallStack) import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), - MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), - ShowMessageParams (..)) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (LogMessageParams (..), + MessageType (..), + ResponseError, + SMethod (SWindowLogMessage, SWindowShowMessage), + ShowMessageParams (..)) #if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) +import Prettyprinter as PrettyPrinterModule +import Prettyprinter.Render.Text (renderStrict) #else -import Data.Text.Prettyprint.Doc as PrettyPrinterModule +import Data.Text.Prettyprint.Doc as PrettyPrinterModule import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) #endif -import System.IO (Handle, IOMode (AppendMode), - hClose, hFlush, hSetEncoding, - openFile, stderr, utf8) -import qualified System.Log.Formatter as HSL -import qualified System.Log.Handler as HSL -import qualified System.Log.Handler.Simple as HSL -import qualified System.Log.Logger as HsLogger -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import Control.Lens ((^.)) +import Ide.Types (CommandId (CommandId), + PluginId (PluginId)) +import Language.LSP.Types.Lens (HasCode (code), + HasMessage (message)) +import System.IO (Handle, + IOMode (AppendMode), + hClose, hFlush, + hSetEncoding, openFile, + stderr, utf8) +import qualified System.Log.Formatter as HSL +import qualified System.Log.Handler as HSL +import qualified System.Log.Handler.Simple as HSL +import qualified System.Log.Logger as HsLogger +import UnliftIO (MonadUnliftIO, + displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -366,3 +381,16 @@ priorityToLsp = Info -> MtInfo Warning -> MtWarning Error -> MtError + +-- ORPHAN Pretty instances -------------------------------------------------------------- +instance Pretty ResponseError where + pretty err = errorCode <> ":" <+> errorBody + where + errorCode = pretty $ show $ err ^. code + errorBody = pretty $ err ^. message + +instance Pretty PluginId where + pretty (PluginId pid) = pretty pid + +instance Pretty CommandId where + pretty (CommandId cid) = pretty cid From b0ab884e8ec403b527045eda6ac8ba8574fe1be7 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Tue, 28 Jun 2022 23:09:47 -0400 Subject: [PATCH 09/10] Revert back to Warning --- ghcide/src/Development/IDE/Plugin/HLS.hs | 10 ++++++++-- ghcide/src/Development/IDE/Types/Logger.hs | 13 ------------- 2 files changed, 8 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index b5d2ef6114..5a2f0a38a3 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -52,9 +52,15 @@ data Log = LogPluginError ResponseError instance Pretty Log where pretty = \case - LogPluginError err -> pretty err + LogPluginError err -> prettyResponseError err -- various error message specific builders +prettyResponseError :: ResponseError -> Doc a +prettyResponseError err = errorCode <> ":" <+> errorBody + where + errorCode = pretty $ show $ err ^. LSP.code + errorBody = pretty $ err ^. LSP.message + pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available:\n" <> T.pack (unlines $ map (\(plid,_,_) -> show plid) availPlugins) @@ -75,7 +81,7 @@ failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder errCode msg = do let err = ResponseError errCode msg Nothing - logWith recorder Error $ LogPluginError err + logWith recorder Warning $ LogPluginError err pure $ Left err -- | Map a set of plugins to the underlying ghcide engine. diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index bb0df3d7df..6673707204 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -381,16 +381,3 @@ priorityToLsp = Info -> MtInfo Warning -> MtWarning Error -> MtError - --- ORPHAN Pretty instances -------------------------------------------------------------- -instance Pretty ResponseError where - pretty err = errorCode <> ":" <+> errorBody - where - errorCode = pretty $ show $ err ^. code - errorBody = pretty $ err ^. message - -instance Pretty PluginId where - pretty (PluginId pid) = pretty pid - -instance Pretty CommandId where - pretty (CommandId cid) = pretty cid From 781fe331825deda9d1af089efef6dc88e2bf03ef Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Wed, 29 Jun 2022 22:24:37 -0400 Subject: [PATCH 10/10] Update log format in test suite --- test/functional/Format.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 1d08d93f9c..af90fc7a9c 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -47,7 +47,7 @@ providerTests = testGroup "formatting provider" [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: [PluginId \"floskell\",PluginId \"fourmolu\",PluginId \"ormolu\",PluginId \"stylish-haskell\",PluginId \"brittany\"]" Nothing) + liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available:\nPluginId \"floskell\"\nPluginId \"fourmolu\"\nPluginId \"ormolu\"\nPluginId \"stylish-haskell\"\nPluginId \"brittany\"\n" Nothing) , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs"