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 -> responseErrorToLogMessage err
+
+responseErrorToLogMessage :: ResponseError -> Doc a
+responseErrorToLogMessage err =  errorCode <> ":" <+> errorBody
+    where
+        errorCode = pretty $ show $ err ^. LSP.code
+        errorBody = pretty $ err ^. LSP.message
+
+-- 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)
+
+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 a)
+logAndReturnError recorder errCode msg = do
+    let err = ResponseError errCode msg Nothing
+    logWith recorder Error $ 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 Warning $ 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

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