Log plugin name and attribute errors to plugins (#3194)

* Log plugin name

* redundant import

* Attribute response error logs to plugins

* remove redundant plugin names from error messages

* improve pretty printing

* Avoid show

* simplify test messages

* Fix

ghcide/src/Development/IDE/Main.hs

@@ -143,7 +143,6 @@ import           System.IO                                (BufferMode (LineBuffe
 import           System.Random                            (newStdGen)
 import           System.Time.Extra                        (Seconds, offsetTime,
                                                            showDuration)
-import           Text.Printf                              (printf)
 
 data Log
   = LogHeapStats !HeapStats.Log

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 (PluginId pId) err -> pretty 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,21 @@ 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 $ join $ NE.zipWith (\(pId,_) -> fmap (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 +244,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
@@ -242,8 +261,8 @@ runConcurrently
   -- ^ Enabled plugin actions that we are allowed to run
   -> a
   -> b
-  -> m (NonEmpty (Either ResponseError d))
-runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do
+  -> 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 InternalError (msg e pid) Nothing)
 

haskell-language-server.cabal

@@ -523,6 +523,7 @@ test-suite func-test
     , lens
     , lens-aeson
     , ghcide
+    , ghcide-test-utils
     , hls-test-utils ^>=1.4
     , lsp-types
     , aeson

plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs

@@ -8,8 +8,7 @@ module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where
 import           Control.Lens                    ((^.))
 import           Control.Monad.Except            (ExceptT, MonadIO, liftIO)
 import qualified Data.HashMap.Strict             as HashMap
-import           Data.String                     (IsString)
-import           Data.Text                       (Text)
+import           Data.Text                       (Text, unpack)
 import qualified Data.Text                       as T
 import           Development.IDE                 (GetParsedModule (GetParsedModule),
                                                   GhcSession (GhcSession),
@@ -43,11 +42,8 @@ instance Pretty Log where
   pretty = \case
     LogShake log -> pretty log
 
-alternateNumberFormatId :: IsString a => a
-alternateNumberFormatId = "alternateNumberFormat"
-
-descriptor :: Recorder (WithPriority Log) -> PluginDescriptor IdeState
-descriptor recorder = (defaultPluginDescriptor alternateNumberFormatId)
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder pId = (defaultPluginDescriptor pId)
     { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler
     , pluginRules = collectLiteralsRule recorder
     }
@@ -87,10 +83,10 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec
         getExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary
 
 codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
-codeActionHandler state _ (CodeActionParams _ _ docId currRange _) = pluginResponse $ do
+codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do
     nfp <- getNormalizedFilePath (docId ^. L.uri)
-    CLR{..} <- requestLiterals state nfp
-    pragma <- getFirstPragma state nfp
+    CLR{..} <- requestLiterals pId state nfp
+    pragma <- getFirstPragma pId state nfp
         -- remove any invalid literals (see validTarget comment)
     let litsInRange = filter inCurrentRange literals
         -- generate alternateFormats and zip with the literal that generated the alternates
@@ -145,16 +141,16 @@ contains Range {_start, _end} x = isInsideRealSrcSpan _start x || isInsideRealSr
 isInsideRealSrcSpan :: Position -> RealSrcSpan -> Bool
 p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p && p <= ep
 
-getFirstPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
-getFirstPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do
-      ghcSession <- liftIO $ runAction (alternateNumberFormatId <> ".GhcSession") state $ useWithStale GhcSession nfp
-      (_, fileContents) <- liftIO $ runAction (alternateNumberFormatId <> ".GetFileContents") state $ getFileContents nfp
+getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
+getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do
+      ghcSession <- liftIO $ runAction (unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp
+      (_, fileContents) <- liftIO $ runAction (unpack pId <> ".GetFileContents") state $ getFileContents nfp
       case ghcSession of
         Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents
         Nothing                                           -> pure Nothing
 
-requestLiterals :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
-requestLiterals state = handleMaybeM "Error: Could not Collect Literals"
+requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
+requestLiterals (PluginId pId) state = handleMaybeM "Could not Collect Literals"
                 . liftIO
-                . runAction (alternateNumberFormatId <> ".CollectLiterals") state
+                . runAction (unpack pId <> ".CollectLiterals") state
                 . use CollectLiterals

plugins/hls-alternate-number-format-plugin/test/Main.hs

@@ -20,7 +20,7 @@ main :: IO ()
 main = defaultTestRunner test
 
 alternateNumberFormatPlugin :: PluginDescriptor IdeState
-alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty
+alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty  "alternateNumberFormat"
 
 -- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time.
 -- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something

plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs

@@ -45,7 +45,7 @@ codeActionHandler ideState _ CodeActionParams {_textDocument = TextDocumentIdent
       pure $ List actions
 
 getDecls :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs]
-getDecls state = handleMaybeM "Error: Could not get Parsed Module"
+getDecls state = handleMaybeM "Could not get Parsed Module"
     . liftIO
     . fmap (fmap (hsmodDecls . unLoc . pm_parsed_source))
     . runAction (changeTypeSignatureId <> ".GetParsedModule") state

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs

@@ -190,7 +190,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe
                 . liftIO
                 . runAction "classplugin.findClassFromIdentifier.TypeCheck" state
                 $ useWithStale TypeCheck docPath
-            handleMaybeM "Error in TcEnv"
+            handleMaybeM "TcEnv"
                 . liftIO
                 . fmap snd
                 . initTcWithGbl hscenv thisMod ghostSpan $ do

plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs

@@ -36,11 +36,8 @@ import           Ide.PluginUtils                      (getNormalizedFilePath,
 import           Ide.Types                            hiding (pluginId)
 import           Language.LSP.Types
 
-pluginId :: PluginId
-pluginId = "explicitFixity"
-
-descriptor :: Recorder (WithPriority Log) -> PluginDescriptor IdeState
-descriptor recorder = (defaultPluginDescriptor pluginId)
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder pluginId = (defaultPluginDescriptor pluginId)
     { pluginRules = fixityRule recorder
     , pluginHandlers = mkPluginHandler STextDocumentHover hover
     -- Make this plugin has a lower priority than ghcide's plugin to ensure
@@ -51,7 +48,7 @@ descriptor recorder = (defaultPluginDescriptor pluginId)
 hover :: PluginMethodHandler IdeState TextDocumentHover
 hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do
     nfp <- getNormalizedFilePath uri
-    fixityTrees <- handleMaybeM "ExplicitFixity: Unable to get fixity"
+    fixityTrees <- handleMaybeM "Unable to get fixity"
         $ liftIO
         $ runAction "ExplicitFixity.GetFixity" state
         $ use GetFixity nfp

plugins/hls-explicit-fixity-plugin/test/Main.hs

@@ -8,7 +8,7 @@ import           System.FilePath
 import           Test.Hls
 
 plugin :: PluginDescriptor IdeState
-plugin = descriptor mempty
+plugin = descriptor mempty "explicit-fixity"
 
 main :: IO ()
 main = defaultTestRunner tests

plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs

@@ -33,7 +33,7 @@ import qualified Data.Text                    as T
 import           Development.IDE              (GetParsedModule (GetParsedModule),
                                                GhcSession (GhcSession),
                                                IdeState, Pretty,
-                                               Priority (Debug, Info), Recorder,
+                                               Priority (Debug), Recorder,
                                                WithPriority, colon, evalGhcEnv,
                                                hscEnvWithImportPaths, logWith,
                                                realSrcSpanToRange, runAction,
@@ -112,7 +112,7 @@ action recorder state uri =
     correctNames <- liftIO $ pathModuleNames recorder state nfp fp
     logWith recorder Debug (CorrectNames correctNames)
     bestName <- minimumBy (comparing T.length) <$> (MaybeT . pure $ NE.nonEmpty correctNames)
-    logWith recorder Info (BestName bestName)
+    logWith recorder Debug (BestName bestName)
 
     statedNameMaybe <- liftIO $ codeModuleName state nfp
     logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe)