Attribute response error logs to plugins

Author: pepeiborra

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

@@ -13,13 +13,16 @@ import           Control.Exception            (SomeException)
 import           Control.Lens                 ((^.))
 import           Control.Monad
 import qualified Data.Aeson                   as J
+import           Data.Bifunctor               (first)
 import           Data.Dependent.Map           (DMap)
 import qualified Data.Dependent.Map           as DMap
 import           Data.Dependent.Sum
 import           Data.Either
 import qualified Data.List                    as List
 import           Data.List.NonEmpty           (NonEmpty, nonEmpty, toList)
+import qualified Data.List.NonEmpty           as NE
 import qualified Data.Map                     as Map
+import           Data.Some
 import           Data.String
 import           Data.Text                    (Text)
 import qualified Data.Text                    as T
@@ -38,6 +41,7 @@ import           Language.LSP.Types
 import qualified Language.LSP.Types           as J
 import qualified Language.LSP.Types.Lens      as LSP
 import           Language.LSP.VFS
+import           Prettyprinter.Render.String  (renderString)
 import           Text.Regex.TDFA.Text         ()
 import           UnliftIO                     (MonadUnliftIO)
 import           UnliftIO.Async               (forConcurrently)
@@ -46,12 +50,18 @@ import           UnliftIO.Exception           (catchAny)
 -- ---------------------------------------------------------------------
 --
 
-data Log = LogPluginError ResponseError
-    deriving Show
-
+data Log
+    = LogPluginError PluginId ResponseError
+    | LogNoPluginForMethod (Some SMethod)
+    | LogInvalidCommandIdentifier
 instance Pretty Log where
   pretty = \case
-    LogPluginError err -> prettyResponseError err
+    LogPluginError pId err -> pretty (show pId) <> ":" <+> prettyResponseError err
+    LogNoPluginForMethod (Some method) ->
+        "No plugin enabled for " <> pretty (show method)
+    LogInvalidCommandIdentifier-> "Invalid command identifier"
+
+instance Show Log where show = renderString . layoutCompact . pretty
 
 -- various error message specific builders
 prettyResponseError :: ResponseError -> Doc a
@@ -77,10 +87,10 @@ 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 a)
-logAndReturnError recorder errCode msg = do
+logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a)
+logAndReturnError recorder p errCode msg = do
     let err = ResponseError errCode msg Nothing
-    logWith recorder Warning $ LogPluginError err
+    logWith recorder Warning $ LogPluginError p err
     pure $ Left err
 
 -- | Map a set of plugins to the underlying ghcide engine.
@@ -164,15 +174,17 @@ executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand ex
         Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams
 
         -- Couldn't parse the command identifier
-        _ -> logAndReturnError recorder InvalidParams "Invalid command Identifier"
+        _ -> do
+            logWith recorder Warning LogInvalidCommandIdentifier
+            return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing
 
     runPluginCommand ide p com arg =
       case Map.lookup p pluginMap  of
-        Nothing -> logAndReturnError recorder InvalidRequest (pluginDoesntExist p)
+        Nothing -> logAndReturnError recorder p InvalidRequest (pluginDoesntExist p)
         Just xs -> case List.find ((com ==) . commandId) xs of
-          Nothing -> logAndReturnError recorder InvalidRequest (commandDoesntExist com p xs)
+          Nothing -> logAndReturnError recorder p InvalidRequest (commandDoesntExist com p xs)
           Just (PluginCommand _ _ f) -> case J.fromJSON arg of
-            J.Error err -> logAndReturnError recorder InvalidParams (failedToParseArgs com p err arg)
+            J.Error err -> logAndReturnError recorder p InvalidParams (failedToParseArgs com p err arg)
             J.Success a -> f ide a
 
 -- ---------------------------------------------------------------------
@@ -195,15 +207,20 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
         let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'
         -- Clients generally don't display ResponseErrors so instead we log any that we come across
         case nonEmpty fs of
-          Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs')
+          Nothing -> do
+            logWith recorder Warning (LogNoPluginForMethod $ Some m)
+            let err = ResponseError InvalidRequest msg Nothing
+                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 (errs,succs) = partitionEithers $ toList es
-            unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err
+            let (errs,succs) = partitionEithers $ toList $ NE.zipWith (\(pId,_) -> first (pId,)) handlers es
+            unless (null errs) $ forM_ errs $ \(pId, err) ->
+                logWith recorder Warning $ LogPluginError pId 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
@@ -226,7 +243,8 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers
         -- Only run plugins that are allowed to run on this request
         let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'
         case nonEmpty fs of
-          Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs')
+          Nothing -> do
+            logWith recorder Warning (LogNoPluginForMethod $ Some m)
           Just fs -> do
             -- We run the notifications in order, so the core ghcide provider
             -- (which restarts the shake process) hopefully comes last