forked from haskell/haskell-language-server
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathExceptionTests.hs
157 lines (149 loc) · 8.22 KB
/
ExceptionTests.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
module ExceptionTests (tests) where
import Control.Exception (ArithException (DivideByZero),
throwIO)
import Control.Lens
import Control.Monad.Error.Class (MonadError (throwError))
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as A
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)
import Ide.Logger (Recorder, WithPriority,
cmapWithPrio)
import Ide.Plugin.Error
import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally))
import Ide.PluginUtils (idePluginsToPluginDesc,
pluginDescToIdePlugins)
import Ide.Types
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types hiding
(SemanticTokenAbsolute (..),
SemanticTokenRelative (..),
SemanticTokensEdit (..),
mkRange)
import Language.LSP.Test
import LogType (Log (..))
import Test.Hls (waitForProgressDone)
import Test.Tasty
import Test.Tasty.HUnit
import TestUtils
tests :: Recorder (WithPriority Log) -> TestTree
tests recorder = do
testGroup "Exceptions and PluginError" [
testGroup "Testing that IO Exceptions are caught in..."
[ testCase "PluginHandlers" $ do
let pluginId = "plugin-handler-exception"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId "")
{ pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
_ <- liftIO $ throwIO DivideByZero
pure (InL [])
]
}]
testIde recorder (testingLite recorder 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 "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
_ -> liftIO $ assertFailure $ show lens
, testCase "Commands" $ do
let pluginId = "command-exception"
commandId = CommandId "exception"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId "")
{ pluginCommands =
[ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do
_ <- liftIO $ throwIO DivideByZero
pure (InR Null)
]
}]
testIde recorder (testingLite recorder plugins) $ do
_ <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)])
execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments)
(view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams
case res of
Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->
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 $
[ (defaultPluginDescriptor pluginId "")
{ pluginNotificationHandlers = mconcat
[ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->
liftIO $ throwIO DivideByZero
]
, pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
pure (InL [])
]
}]
testIde recorder (testingLite recorder 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..."
[ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test")
, pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test")
, pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally)
]
]
testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments
testingLite recorder plugins =
let
[email protected]{ argsIdeOptions } =
IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins
hlsPlugins = pluginDescToIdePlugins $
idePluginsToPluginDesc plugins
++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
++ [Test.blockCommandDescriptor "block-command", Test.plugin]
ideOptions config sessionLoader =
let
defOptions = argsIdeOptions config sessionLoader
in
defOptions{ optTesting = IdeTesting True }
in
arguments
{ IDE.argsHlsPlugins = hlsPlugins
, IDE.argsIdeOptions = ideOptions
}
pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree
pluginOrderTestCase recorder msg err1 err2 =
testCase msg $ do
let pluginId = "error-order-test"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId "")
{ pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError err1
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError err2
]
}]
testIde recorder (testingLite recorder 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) == re -> pure ()
| otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"
_ -> liftIO $ assertFailure $ show lens