Log response errors returned from Plugins

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)
@@ -44,20 +47,48 @@ import           UnliftIO.Exception           (catchAny)
 -- ---------------------------------------------------------------------
 --
 
-data Log
-  = LogNoEnabledPlugins
-  deriving Show
+data Log = LogPluginError ResponseError
+    deriving Show
 
 instance Pretty Log where
   pretty = \case
-    LogNoEnabledPlugins ->
-      "extensibleNotificationPlugins no enabled plugins"
+    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)
+
+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:\n" <> T.pack (unlines $ map (show . 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 a)
+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) id <>
     mkPlugin (extensibleNotificationPlugins recorder) id <>
     mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags
@@ -91,11 +122,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
 
@@ -134,21 +165,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
 
 -- ---------------------------------------------------------------------
@@ -169,19 +194,15 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
         config <- Ide.PluginUtils.getClientConfig
         -- Only run plugins that are allowed to run on this request
         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 -> do
-            logWith recorder Info LogNoEnabledPlugins
-            pure $ Left $ ResponseError InvalidRequest
-              (  "No plugin enabled for " <> T.pack (show m) 
-              <> ", available: " <> T.pack (show $ map (\(plid,_,_) -> plid) fs)
-              )
-              Nothing
+          Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs')
           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 Error $ LogPluginError err
             case nonEmpty succs of
               Nothing -> pure $ Left $ combineErrors errs
               Just xs -> do
@@ -206,9 +227,7 @@ 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 -> do
-            logWith recorder Info LogNoEnabledPlugins
-            pure ()
+          Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs')
           Just fs -> do
             -- We run the notifications in order, so the core ghcide provider
             -- (which restarts the shake process) hopefully comes last
@@ -227,7 +246,7 @@ runConcurrently
   -> m (NonEmpty (Either 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)
+     `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)
 
 combineErrors :: [ResponseError] -> ResponseError
 combineErrors [x] = x

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

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

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

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

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:\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"