Skip to content

Commit ec1e6c1

Browse files
joyfulmantisjoyfulmantis
authored
Various PluginError PR suggestions I missed earlier (#3737)
1 parent 8d7555c commit ec1e6c1

File tree

6 files changed

+116
-248
lines changed

6 files changed

+116
-248
lines changed

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -964,7 +964,7 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file)
964964
-- |Request a Rule result, it not available return the last computed result
965965
-- which may be stale.
966966
--
967-
-- Throws an `BadDependency` IO exception which is caught by the rule system if
967+
-- Throws an `BadDependency` exception which is caught by the rule system if
968968
-- none available.
969969
--
970970
-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead.
@@ -974,7 +974,7 @@ useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file)
974974

975975
-- |Plural version of 'useWithStale_'
976976
--
977-
-- Throws an `BadDependency` IO exception which is caught by the rule system if
977+
-- Throws an `BadDependency` exception which is caught by the rule system if
978978
-- none available.
979979
--
980980
-- WARNING: Not suitable for PluginHandlers.
@@ -1053,7 +1053,7 @@ useNoFile key = use key emptyFilePath
10531053

10541054
-- Requests a rule if available.
10551055
--
1056-
-- Throws an `BadDependency` IO exception which is caught by the rule system if
1056+
-- Throws an `BadDependency` exception which is caught by the rule system if
10571057
-- none available.
10581058
--
10591059
-- WARNING: Not suitable for PluginHandlers. Use `useE` instead.
@@ -1065,7 +1065,7 @@ useNoFile_ key = use_ key emptyFilePath
10651065

10661066
-- |Plural version of `use_`
10671067
--
1068-
-- Throws an `BadDependency` IO exception which is caught by the rule system if
1068+
-- Throws an `BadDependency` exception which is caught by the rule system if
10691069
-- none available.
10701070
--
10711071
-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead.

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

Lines changed: 24 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
module Development.IDE.Plugin.HLS
77
(
88
asGhcIdePlugin
9+
, toResponseError
910
, Log(..)
1011
) where
1112

@@ -80,11 +81,17 @@ prettyResponseError err = errorCode <> ":" <+> errorBody
8081
errorCode = pretty $ show $ err ^. L.code
8182
errorBody = pretty $ err ^. L.message
8283

83-
pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text
84-
pluginNotEnabled method availPlugins =
85-
"No plugin enabled for " <> T.pack (show method) <> ", potentially available: "
86-
<> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins)
87-
84+
noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c)
85+
noPluginEnabled recorder m fs' = do
86+
logWith recorder Warning (LogNoPluginForMethod $ Some m)
87+
let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing
88+
msg = pluginNotEnabled m fs'
89+
return $ Left err
90+
where pluginNotEnabled :: SMethod m -> [PluginId] -> Text
91+
pluginNotEnabled method availPlugins =
92+
"No plugin enabled for " <> T.pack (show method) <> ", potentially available: "
93+
<> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins)
94+
8895
pluginDoesntExist :: PluginId -> Text
8996
pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist"
9097

@@ -113,13 +120,6 @@ logAndReturnError recorder p errCode msg = do
113120
logWith recorder Warning $ LogResponseError p err
114121
pure $ Left err
115122

116-
-- | Logs the provider error before returning it to the caller
117-
logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a)
118-
logAndReturnError' recorder errCode msg = do
119-
let err = ResponseError errCode (fromString $ show msg) Nothing
120-
logWith recorder Warning $ msg
121-
pure $ Left err
122-
123123
-- | Map a set of plugins to the underlying ghcide engine.
124124
asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config
125125
asGhcIdePlugin recorder (IdePlugins ls) =
@@ -219,8 +219,15 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom
219219
Just (PluginCommand _ _ f) -> case A.fromJSON arg of
220220
A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)
221221
A.Success a -> do
222-
(first (toResponseError . (p,)) <$> runExceptT (f ide a)) `catchAny` -- See Note [Exception handling in plugins]
223-
(\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e))
222+
res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins]
223+
(\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))
224+
case res of
225+
(Left (PluginRequestRefused _)) ->
226+
liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs)
227+
(Left pluginErr) -> do
228+
liftIO $ logErrors recorder [(p, pluginErr)]
229+
pure $ Left $ toResponseError (p, pluginErr)
230+
(Right result) -> pure $ Right result
224231

225232
-- ---------------------------------------------------------------------
226233

@@ -242,7 +249,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
242249
let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'
243250
-- Clients generally don't display ResponseErrors so instead we log any that we come across
244251
case nonEmpty fs of
245-
Nothing -> liftIO $ noPluginEnabled m fs'
252+
Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')
246253
Just fs -> do
247254
let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs
248255
es <- runConcurrently exceptionInPlugin m handlers ide params
@@ -255,16 +262,11 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
255262
noRefused (_, _) = True
256263
filteredErrs = filter noRefused errs
257264
case nonEmpty filteredErrs of
258-
Nothing -> liftIO $ noPluginEnabled m fs'
265+
Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')
259266
Just xs -> pure $ Left $ combineErrors xs
260267
Just xs -> do
261268
pure $ Right $ combineResponses m config caps params xs
262-
noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c)
263-
noPluginEnabled m fs' = do
264-
logWith recorder Warning (LogNoPluginForMethod $ Some m)
265-
let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing
266-
msg = pluginNotEnabled m fs'
267-
return $ Left err
269+
268270

269271
-- ---------------------------------------------------------------------
270272

@@ -313,7 +315,6 @@ combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError
313315
combineErrors (x NE.:| []) = toResponseError x
314316
combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs
315317

316-
317318
toResponseError :: (PluginId, PluginError) -> ResponseError
318319
toResponseError (PluginId plId, err) =
319320
ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing

‎ghcide/test/exe/ExceptionTests.hs‎

Lines changed: 34 additions & 91 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,8 @@
11

22
module ExceptionTests (tests) where
33

4-
import Control.Concurrent.Async
54
import Control.Exception (ArithException (DivideByZero),
6-
finally, throwIO)
5+
throwIO)
76
import Control.Lens
87
import Control.Monad.Error.Class (MonadError (throwError))
98
import Control.Monad.IO.Class (liftIO)
@@ -12,6 +11,7 @@ import Data.Text as T
1211
import Development.IDE.Core.Shake (IdeState (..))
1312
import qualified Development.IDE.LSP.Notifications as Notifications
1413
import qualified Development.IDE.Main as IDE
14+
import Development.IDE.Plugin.HLS (toResponseError)
1515
import Development.IDE.Plugin.Test as Test
1616
import Development.IDE.Types.Options
1717
import GHC.Base (coerce)
@@ -30,8 +30,6 @@ import Language.LSP.Protocol.Types hiding
3030
mkRange)
3131
import Language.LSP.Test
3232
import LogType (Log (..))
33-
import System.Directory
34-
import System.Process.Extra (createPipe)
3533
import Test.Tasty
3634
import Test.Tasty.HUnit
3735
import TestUtils
@@ -50,7 +48,6 @@ tests recorder logger = do
5048
pure (InL [])
5149
]
5250
}]
53-
5451
testIde recorder (testingLite recorder logger plugins) $ do
5552
doc <- createDoc "A.hs" "haskell" "module A where"
5653
waitForProgressDone
@@ -60,6 +57,7 @@ tests recorder logger = do
6057
liftIO $ assertBool "We caught an error, but it wasn't ours!"
6158
(T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
6259
_ -> liftIO $ assertFailure $ show lens
60+
6361
, testCase "Commands" $ do
6462
let pluginId = "command-exception"
6563
commandId = CommandId "exception"
@@ -71,7 +69,6 @@ tests recorder logger = do
7169
pure (InR Null)
7270
]
7371
}]
74-
7572
testIde recorder (testingLite recorder logger plugins) $ do
7673
_ <- createDoc "A.hs" "haskell" "module A where"
7774
waitForProgressDone
@@ -83,6 +80,7 @@ tests recorder logger = do
8380
liftIO $ assertBool "We caught an error, but it wasn't ours!"
8481
(T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
8582
_ -> liftIO $ assertFailure $ show res
83+
8684
, testCase "Notification Handlers" $ do
8785
let pluginId = "notification-exception"
8886
plugins = pluginDescToIdePlugins $
@@ -95,101 +93,24 @@ tests recorder logger = do
9593
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
9694
pure (InL [])
9795
]
98-
}
99-
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
100-
96+
}]
10197
testIde recorder (testingLite recorder logger plugins) $ do
10298
doc <- createDoc "A.hs" "haskell" "module A where"
10399
waitForProgressDone
104100
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
105101
case lens of
106102
Right (InL []) ->
103+
-- We don't get error responses from notification handlers, so
104+
-- we can only make sure that the server is still responding
107105
pure ()
108106
_ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]
109107

110108
, testGroup "Testing PluginError order..."
111-
[ testCase "InternalError over InvalidParams" $ do
112-
let pluginId = "internal-error-order"
113-
plugins = pluginDescToIdePlugins $
114-
[ (defaultPluginDescriptor pluginId)
115-
{ pluginHandlers = mconcat
116-
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
117-
throwError $ PluginInternalError "error test"
118-
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
119-
throwError $ PluginInvalidParams "error test"
120-
]
121-
}
122-
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
123-
124-
testIde recorder (testingLite recorder logger plugins) $ do
125-
doc <- createDoc "A.hs" "haskell" "module A where"
126-
waitForProgressDone
127-
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
128-
case lens of
129-
Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->
130-
liftIO $ assertBool "We caught an error, but it wasn't ours!"
131-
(T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
132-
_ -> liftIO $ assertFailure $ show lens
133-
, testCase "InvalidParams over InvalidUserState" $ do
134-
let pluginId = "invalid-params-order"
135-
plugins = pluginDescToIdePlugins $
136-
[ (defaultPluginDescriptor pluginId)
137-
{ pluginHandlers = mconcat
138-
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
139-
throwError $ PluginInvalidParams "error test"
140-
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
141-
throwError $ PluginInvalidUserState "error test"
142-
]
143-
}
144-
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
145-
146-
testIde recorder (testingLite recorder logger plugins) $ do
147-
doc <- createDoc "A.hs" "haskell" "module A where"
148-
waitForProgressDone
149-
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
150-
case lens of
151-
Left (ResponseError {_code = InR ErrorCodes_InvalidParams, _message}) ->
152-
liftIO $ assertBool "We caught an error, but it wasn't ours!"
153-
(T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
154-
_ -> liftIO $ assertFailure $ show lens
155-
, testCase "InvalidUserState over RequestRefused" $ do
156-
let pluginId = "invalid-user-state-order"
157-
plugins = pluginDescToIdePlugins $
158-
[ (defaultPluginDescriptor pluginId)
159-
{ pluginHandlers = mconcat
160-
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
161-
throwError $ PluginInvalidUserState "error test"
162-
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
163-
throwError $ PluginRequestRefused "error test"
164-
]
165-
}
166-
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
167-
168-
testIde recorder (testingLite recorder logger plugins) $ do
169-
doc <- createDoc "A.hs" "haskell" "module A where"
170-
waitForProgressDone
171-
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
172-
case lens of
173-
Left (ResponseError {_code = InL LSPErrorCodes_RequestFailed, _message}) ->
174-
liftIO $ assertBool "We caught an error, but it wasn't ours!"
175-
(T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
176-
_ -> liftIO $ assertFailure $ show lens
177-
]]
178-
179-
testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()
180-
testIde recorder arguments session = do
181-
config <- getConfigFromEnv
182-
cwd <- getCurrentDirectory
183-
(hInRead, hInWrite) <- createPipe
184-
(hOutRead, hOutWrite) <- createPipe
185-
let projDir = "."
186-
let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
187-
{ IDE.argsHandleIn = pure hInRead
188-
, IDE.argsHandleOut = pure hOutWrite
189-
}
190-
191-
flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->
192-
runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session
109+
[ pluginOrderTestCase recorder logger "InternalError over InvalidParams" PluginInternalError PluginInvalidParams
110+
, pluginOrderTestCase recorder logger "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState
111+
, pluginOrderTestCase recorder logger "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused
112+
]
113+
]
193114

194115
testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments
195116
testingLite recorder logger plugins =
@@ -210,3 +131,25 @@ testingLite recorder logger plugins =
210131
{ IDE.argsHlsPlugins = hlsPlugins
211132
, IDE.argsIdeOptions = ideOptions
212133
}
134+
135+
pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree
136+
pluginOrderTestCase recorder logger msg err1 err2 =
137+
testCase msg $ do
138+
let pluginId = "error-order-test"
139+
plugins = pluginDescToIdePlugins $
140+
[ (defaultPluginDescriptor pluginId)
141+
{ pluginHandlers = mconcat
142+
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
143+
throwError $ err1 "error test"
144+
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
145+
throwError $ err2 "error test"
146+
]
147+
}]
148+
testIde recorder (testingLite recorder logger plugins) $ do
149+
doc <- createDoc "A.hs" "haskell" "module A where"
150+
waitForProgressDone
151+
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
152+
case lens of
153+
Left re | toResponseError (pluginId, err1 "error test") == re -> pure ()
154+
| otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"
155+
_ -> liftIO $ assertFailure $ show lens

0 commit comments

Comments
 (0)