Various PluginError PR suggestions I missed earlier

ghcide/src/Development/IDE/Core/Shake.hs

@@ -964,7 +964,7 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file)
 -- |Request a Rule result, it not available return the last computed result
 --  which may be stale.
 --
--- Throws an `BadDependency` IO exception which is caught by the rule system if
+-- Throws an `BadDependency` exception which is caught by the rule system if
 -- none available.
 --
 -- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead.
@@ -974,7 +974,7 @@ useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file)
 
 -- |Plural version of 'useWithStale_'
 --
--- Throws an `BadDependency` IO exception which is caught by the rule system if
+-- Throws an `BadDependency` exception which is caught by the rule system if
 -- none available.
 --
 -- WARNING: Not suitable for PluginHandlers.
@@ -1053,7 +1053,7 @@ useNoFile key = use key emptyFilePath
 
 -- Requests a rule if available.
 --
--- Throws an `BadDependency` IO exception which is caught by the rule system if
+-- Throws an `BadDependency` exception which is caught by the rule system if
 -- none available.
 --
 -- WARNING: Not suitable for PluginHandlers. Use `useE` instead.
@@ -1065,7 +1065,7 @@ useNoFile_ key = use_ key emptyFilePath
 
 -- |Plural version of `use_`
 --
--- Throws an `BadDependency` IO exception which is caught by the rule system if
+-- Throws an `BadDependency` exception which is caught by the rule system if
 -- none available.
 --
 -- WARNING: Not suitable for PluginHandlers. Use `usesE` instead.

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

@@ -6,6 +6,7 @@
 module Development.IDE.Plugin.HLS
     (
       asGhcIdePlugin
+    , toResponseError
     , Log(..)
     ) where
 
@@ -80,11 +81,17 @@ prettyResponseError err = errorCode <> ":" <+> errorBody
         errorCode = pretty $ show $ err ^. L.code
         errorBody = pretty $ err ^. L.message
 
-pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text
-pluginNotEnabled method availPlugins =
-    "No plugin enabled for " <> T.pack (show method) <> ", potentially available: "
-        <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins)
-
+noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c)
+noPluginEnabled recorder m fs' = do
+  logWith recorder Warning (LogNoPluginForMethod $ Some m)
+  let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing
+      msg = pluginNotEnabled m fs'
+  return $ Left err
+  where pluginNotEnabled :: SMethod m -> [PluginId] -> Text
+        pluginNotEnabled method availPlugins =
+            "No plugin enabled for " <> T.pack (show method) <> ", potentially available: "
+                <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins)
+
 pluginDoesntExist :: PluginId -> Text
 pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist"
 
@@ -113,13 +120,6 @@ logAndReturnError recorder p errCode msg = do
     logWith recorder Warning $ LogResponseError p err
     pure $ Left err
 
--- | Logs the provider error before returning it to the caller
-logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a)
-logAndReturnError' recorder errCode msg = do
-    let err = ResponseError errCode (fromString $ show msg) Nothing
-    logWith recorder Warning $ msg
-    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) =
@@ -219,8 +219,15 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom
           Just (PluginCommand _ _ f) -> case A.fromJSON arg of
             A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)
             A.Success a -> do
-              (first (toResponseError . (p,)) <$> runExceptT (f ide a)) `catchAny` -- See Note [Exception handling in plugins]
-                (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e))
+              res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins]
+                (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))
+              case res of
+                (Left (PluginRequestRefused _)) ->
+                  liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs)
+                (Left pluginErr) -> do
+                  liftIO $ logErrors recorder [(p, pluginErr)]
+                  pure $ Left $ toResponseError (p, pluginErr)
+                (Right result) -> pure $ Right result
 
 -- ---------------------------------------------------------------------
 
@@ -242,7 +249,7 @@ 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 -> liftIO $ noPluginEnabled m fs'
+          Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')
           Just fs -> do
             let  handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs
             es <- runConcurrently exceptionInPlugin m handlers ide params
@@ -255,16 +262,11 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
                     noRefused (_, _)                      = True
                     filteredErrs = filter noRefused errs
                 case nonEmpty filteredErrs of
-                  Nothing -> liftIO $ noPluginEnabled m fs'
+                  Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')
                   Just xs -> pure $ Left $ combineErrors xs
               Just xs -> do
                 pure $ Right $ combineResponses m config caps params xs
-    noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c)
-    noPluginEnabled m fs' = do
-      logWith recorder Warning (LogNoPluginForMethod $ Some m)
-      let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing
-          msg = pluginNotEnabled m fs'
-      return $ Left err
+
 
 -- ---------------------------------------------------------------------
 
@@ -313,7 +315,6 @@ combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError
 combineErrors (x NE.:| []) = toResponseError x
 combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs
 
-
 toResponseError :: (PluginId, PluginError) -> ResponseError
 toResponseError (PluginId plId, err) =
         ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing

ghcide/test/exe/ExceptionTests.hs

@@ -1,9 +1,8 @@
 
 module ExceptionTests (tests) where
 
-import           Control.Concurrent.Async
 import           Control.Exception                 (ArithException (DivideByZero),
-                                                    finally, throwIO)
+                                                    throwIO)
 import           Control.Lens
 import           Control.Monad.Error.Class         (MonadError (throwError))
 import           Control.Monad.IO.Class            (liftIO)
@@ -12,6 +11,7 @@ import           Data.Text                         as T
 import           Development.IDE.Core.Shake        (IdeState (..))
 import qualified Development.IDE.LSP.Notifications as Notifications
 import qualified Development.IDE.Main              as IDE
+import           Development.IDE.Plugin.HLS        (toResponseError)
 import           Development.IDE.Plugin.Test       as Test
 import           Development.IDE.Types.Options
 import           GHC.Base                          (coerce)
@@ -30,8 +30,6 @@ import           Language.LSP.Protocol.Types       hiding
                                                     mkRange)
 import           Language.LSP.Test
 import           LogType                           (Log (..))
-import           System.Directory
-import           System.Process.Extra              (createPipe)
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           TestUtils
@@ -50,7 +48,6 @@ tests recorder logger = do
                               pure (InL [])
                           ]
                       }]
-
           testIde recorder (testingLite recorder logger plugins) $ do
               doc <- createDoc "A.hs" "haskell" "module A where"
               waitForProgressDone
@@ -60,6 +57,7 @@ tests recorder logger = do
                   liftIO $ assertBool "We caught an error, but it wasn't ours!"
                           (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
                 _ -> liftIO $ assertFailure $ show lens
+
         , testCase "Commands" $ do
           let pluginId = "command-exception"
               commandId = CommandId "exception"
@@ -71,7 +69,6 @@ tests recorder logger = do
                               pure (InR Null)
                           ]
                       }]
-
           testIde recorder (testingLite recorder logger plugins) $ do
               _ <- createDoc "A.hs" "haskell" "module A where"
               waitForProgressDone
@@ -83,6 +80,7 @@ tests recorder logger = do
                   liftIO $ assertBool "We caught an error, but it wasn't ours!"
                           (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
                 _ -> liftIO $ assertFailure $ show res
+
         , testCase "Notification Handlers" $ do
           let pluginId = "notification-exception"
               plugins = pluginDescToIdePlugins $
@@ -95,101 +93,24 @@ tests recorder logger = do
                           [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
                               pure (InL [])
                           ]
-                      }
-                    , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
-
+                      }]
           testIde recorder (testingLite recorder logger plugins) $ do
               doc <- createDoc "A.hs" "haskell" "module A where"
               waitForProgressDone
               (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
               case lens of
                 Right (InL []) ->
+                  -- We don't get error responses from notification handlers, so
+                  -- we can only make sure that the server is still responding
                   pure ()
                 _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]
 
    , testGroup "Testing PluginError order..."
-      [ testCase "InternalError over InvalidParams" $ do
-        let pluginId = "internal-error-order"
-            plugins = pluginDescToIdePlugins $
-                [ (defaultPluginDescriptor pluginId)
-                    { pluginHandlers = mconcat
-                        [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
-                            throwError $ PluginInternalError "error test"
-                         ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
-                            throwError $ PluginInvalidParams "error test"
-                        ]
-                    }
-                  , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
-
-        testIde recorder (testingLite recorder logger plugins) $ do
-            doc <- createDoc "A.hs" "haskell" "module A where"
-            waitForProgressDone
-            (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
-            case lens of
-              Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->
-                  liftIO $ assertBool "We caught an error, but it wasn't ours!"
-                          (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
-              _ -> liftIO $ assertFailure $ show lens
-      , testCase "InvalidParams over InvalidUserState" $ do
-        let pluginId = "invalid-params-order"
-            plugins = pluginDescToIdePlugins $
-                [ (defaultPluginDescriptor pluginId)
-                    { pluginHandlers = mconcat
-                        [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
-                            throwError $ PluginInvalidParams "error test"
-                         ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
-                            throwError $ PluginInvalidUserState "error test"
-                        ]
-                    }
-                  , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
-
-        testIde recorder (testingLite recorder logger plugins) $ do
-            doc <- createDoc "A.hs" "haskell" "module A where"
-            waitForProgressDone
-            (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
-            case lens of
-              Left (ResponseError {_code = InR ErrorCodes_InvalidParams, _message}) ->
-                  liftIO $ assertBool "We caught an error, but it wasn't ours!"
-                          (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
-              _ -> liftIO $ assertFailure $ show lens
-      , testCase "InvalidUserState over RequestRefused" $ do
-        let pluginId = "invalid-user-state-order"
-            plugins = pluginDescToIdePlugins $
-                [ (defaultPluginDescriptor pluginId)
-                    { pluginHandlers = mconcat
-                        [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
-                            throwError $ PluginInvalidUserState "error test"
-                         ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
-                            throwError $ PluginRequestRefused "error test"
-                        ]
-                    }
-                  , Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
-
-        testIde recorder (testingLite recorder logger plugins) $ do
-            doc <- createDoc "A.hs" "haskell" "module A where"
-            waitForProgressDone
-            (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
-            case lens of
-              Left (ResponseError {_code = InL LSPErrorCodes_RequestFailed, _message}) ->
-                  liftIO $ assertBool "We caught an error, but it wasn't ours!"
-                          (T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
-              _ -> liftIO $ assertFailure $ show lens
-     ]]
-
-testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()
-testIde recorder arguments session = do
-    config <- getConfigFromEnv
-    cwd <- getCurrentDirectory
-    (hInRead, hInWrite) <- createPipe
-    (hOutRead, hOutWrite) <- createPipe
-    let projDir = "."
-    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
-            { IDE.argsHandleIn = pure hInRead
-            , IDE.argsHandleOut = pure hOutWrite
-            }
-
-    flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->
-        runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session
+      [ pluginOrderTestCase recorder logger  "InternalError over InvalidParams" PluginInternalError PluginInvalidParams
+      , pluginOrderTestCase recorder logger  "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState
+      , pluginOrderTestCase recorder logger  "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused
+      ]
+   ]
 
 testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments
 testingLite recorder logger plugins =
@@ -210,3 +131,25 @@ testingLite recorder logger plugins =
       { IDE.argsHlsPlugins = hlsPlugins
       , IDE.argsIdeOptions = ideOptions
       }
+
+pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree
+pluginOrderTestCase recorder logger msg err1 err2 =
+  testCase msg $ do
+      let pluginId = "error-order-test"
+          plugins = pluginDescToIdePlugins $
+              [ (defaultPluginDescriptor pluginId)
+                  { pluginHandlers = mconcat
+                      [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
+                          throwError $ err1 "error test"
+                        ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
+                          throwError $ err2 "error test"
+                      ]
+                  }]
+      testIde recorder (testingLite recorder logger plugins) $ do
+          doc <- createDoc "A.hs" "haskell" "module A where"
+          waitForProgressDone
+          (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
+          case lens of
+            Left re | toResponseError (pluginId, err1 "error test") == re -> pure ()
+                    | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"
+            _ -> liftIO $ assertFailure $ show lens