1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
9 import qualified Data.HashMap.Strict as HM
11 import qualified Data.Text as T
12 import Control.Applicative.Combinators
13 import Control.Concurrent
14 import Control.Monad.IO.Class
16 import Control.Lens hiding (List)
18 import Language.Haskell.LSP.Messages
19 import Language.Haskell.LSP.Test
20 import Language.Haskell.LSP.Test.Replay
21 import Language.Haskell.LSP.Types
22 import Language.Haskell.LSP.Types.Lens as LSP hiding
23 (capabilities, message, rename, applyEdit)
24 import Language.Haskell.LSP.Types.Capabilities as LSP
27 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
28 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
31 describe "Session" $ do
33 let session = runSession "hie" fullCaps "test/data/renamePass" $ do
34 openDoc "Desktop/simple.hs" "haskell"
35 skipMany loggingNotification
37 in session `shouldThrow` anySessionException
38 it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do
39 rsp <- initializeResponse
40 liftIO $ rsp ^. result `shouldNotBe` Nothing
42 it "runSessionWithConfig" $
43 runSession "hie" didChangeCaps "test/data/renamePass" $ return ()
45 describe "withTimeout" $ do
47 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
48 openDoc "Desktop/simple.hs" "haskell"
49 -- won't receive a request - will timeout
50 -- incoming logging requests shouldn't increase the
52 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
53 -- wait just a bit longer than 5 seconds so we have time
54 -- to open the document
55 in timeout 6000000 sesh `shouldThrow` anySessionException
57 it "doesn't time out" $
58 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
59 openDoc "Desktop/simple.hs" "haskell"
60 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
61 in void $ timeout 6000000 sesh
63 it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do
64 doc <- openDoc "Desktop/simple.hs" "haskell"
65 withTimeout 3 $ getDocumentSymbols doc
66 liftIO $ threadDelay 5000000
67 -- shouldn't throw an exception
68 getDocumentSymbols doc
71 it "overrides global message timeout" $
73 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
74 doc <- openDoc "Desktop/simple.hs" "haskell"
75 -- shouldn't time out in here since we are overriding it
76 withTimeout 10 $ liftIO $ threadDelay 7000000
77 getDocumentSymbols doc
79 in sesh `shouldReturn` True
81 it "unoverrides global message timeout" $
83 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
84 doc <- openDoc "Desktop/simple.hs" "haskell"
85 -- shouldn't time out in here since we are overriding it
86 withTimeout 10 $ liftIO $ threadDelay 7000000
87 getDocumentSymbols doc
89 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
90 in sesh `shouldThrow` (== Timeout)
93 describe "SessionException" $ do
94 it "throw on time out" $
95 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do
96 skipMany loggingNotification
97 _ <- message :: Session ApplyWorkspaceEditRequest
99 in sesh `shouldThrow` anySessionException
101 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do
103 liftIO $ threadDelay 10
104 _ <- openDoc "Desktop/simple.hs" "haskell"
107 describe "UnexpectedMessageException" $ do
108 it "throws when there's an unexpected message" $
109 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
111 in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
112 it "provides the correct types that were expected and received" $
113 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
116 doc <- openDoc "Desktop/simple.hs" "haskell"
117 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
118 skipMany anyNotification
119 message :: Session RenameResponse -- the wrong type
120 in runSession "hie" fullCaps "test/data/renamePass" sesh
121 `shouldThrow` selector
123 describe "replaySession" $
124 -- This is too fickle at the moment
125 -- it "passes a test" $
126 -- replaySession "hie" "test/data/renamePass"
128 let selector (ReplayOutOfOrder _ _) = True
130 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
132 describe "manual javascript session" $
134 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
135 doc <- openDoc "test.js" "javascript"
139 Right (fooSymbol:_) <- getDocumentSymbols doc
142 fooSymbol ^. name `shouldBe` "foo"
143 fooSymbol ^. kind `shouldBe` SkFunction
145 describe "text document VFS" $
146 it "sends back didChange notifications" $
147 runSession "hie" def "test/data/refactor" $ do
148 doc <- openDoc "Main.hs" "haskell"
150 let args = toJSON $ AOP (doc ^. uri)
153 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
154 request_ WorkspaceExecuteCommand reqParams
156 editReq <- message :: Session ApplyWorkspaceEditRequest
158 let (Just cs) = editReq ^. params . edit . changes
159 [(u, List es)] = HM.toList cs
160 u `shouldBe` doc ^. uri
161 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
165 contents <- documentContents doc
166 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
168 describe "getDocumentEdit" $
169 it "automatically consumes applyedit requests" $
170 runSession "hie" fullCaps "test/data/refactor" $ do
171 doc <- openDoc "Main.hs" "haskell"
173 let args = toJSON $ AOP (doc ^. uri)
176 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
177 request_ WorkspaceExecuteCommand reqParams
178 contents <- getDocumentEdit doc
179 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
182 describe "getCodeActions" $
183 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
184 doc <- openDoc "Main.hs" "haskell"
186 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
187 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
189 describe "getAllCodeActions" $
190 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
191 doc <- openDoc "Main.hs" "haskell"
192 _ <- waitForDiagnostics
193 actions <- getAllCodeActions doc
195 let [CACodeAction action] = actions
196 action ^. title `shouldBe` "Apply hint:Redundant bracket"
197 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
199 describe "getDocumentSymbols" $
200 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
201 doc <- openDoc "Desktop/simple.hs" "haskell"
203 skipMany loggingNotification
207 Left (mainSymbol:_) <- getDocumentSymbols doc
210 mainSymbol ^. name `shouldBe` "main"
211 mainSymbol ^. kind `shouldBe` SkFunction
212 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
214 describe "applyEdit" $ do
215 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
216 doc <- openDoc "Desktop/simple.hs" "haskell"
217 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
218 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
219 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
220 liftIO $ newVersion `shouldBe` oldVersion + 1
221 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
222 doc <- openDoc "Desktop/simple.hs" "haskell"
223 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
225 contents <- documentContents doc
226 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
228 describe "getCompletions" $
229 it "works" $ runSession "hie" def "test/data/renamePass" $ do
230 doc <- openDoc "Desktop/simple.hs" "haskell"
232 -- wait for module to be loaded
233 skipMany loggingNotification
237 item:_ <- getCompletions doc (Position 5 5)
239 item ^. label `shouldBe` "interactWithUser"
240 item ^. kind `shouldBe` Just CiFunction
241 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
243 describe "getReferences" $
244 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
245 doc <- openDoc "Desktop/simple.hs" "haskell"
246 let pos = Position 40 3 -- interactWithUser
248 refs <- getReferences doc pos True
249 liftIO $ refs `shouldContain` map (Location uri) [
255 describe "getDefinitions" $
256 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
257 doc <- openDoc "Desktop/simple.hs" "haskell"
258 let pos = Position 49 25 -- addItem
259 defs <- getDefinitions doc pos
260 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
262 describe "getTypeDefinitions" $
263 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
264 doc <- openDoc "Desktop/simple.hs" "haskell"
265 let pos = Position 20 23 -- Quit value
266 defs <- getTypeDefinitions doc pos
267 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 15 10 19)] -- First constructor
269 describe "waitForDiagnosticsSource" $
270 it "works" $ runSession "hie" fullCaps "test/data" $ do
271 openDoc "Error.hs" "haskell"
272 [diag] <- waitForDiagnosticsSource "ghcmod"
274 diag ^. severity `shouldBe` Just DsError
275 diag ^. source `shouldBe` Just "ghcmod"
278 it "works" $ runSession "hie" fullCaps "test/data" $ do
279 doc <- openDoc "Rename.hs" "haskell"
280 rename doc (Position 1 0) "bar"
281 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
283 describe "getHover" $
284 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
285 doc <- openDoc "Desktop/simple.hs" "haskell"
286 -- hover returns nothing until module is loaded
287 skipManyTill loggingNotification $ count 2 noDiagnostics
288 hover <- getHover doc (Position 45 9) -- putStrLn
289 liftIO $ hover `shouldSatisfy` isJust
291 describe "getHighlights" $
292 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
293 doc <- openDoc "Desktop/simple.hs" "haskell"
294 skipManyTill loggingNotification $ count 2 noDiagnostics
295 highlights <- getHighlights doc (Position 27 4) -- addItem
296 liftIO $ length highlights `shouldBe` 4
298 describe "formatDoc" $
299 it "works" $ runSession "hie" fullCaps "test/data" $ do
300 doc <- openDoc "Format.hs" "haskell"
301 oldContents <- documentContents doc
302 formatDoc doc (FormattingOptions 4 True)
303 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
305 describe "formatRange" $
306 it "works" $ runSession "hie" fullCaps "test/data" $ do
307 doc <- openDoc "Format.hs" "haskell"
308 oldContents <- documentContents doc
309 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
310 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
312 describe "closeDoc" $
315 runSession "hie" fullCaps "test/data" $ do
316 doc <- openDoc "Format.hs" "haskell"
318 -- need to evaluate to throw
319 documentContents doc >>= liftIO . print
320 in sesh `shouldThrow` anyException
322 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
324 didChangeCaps :: ClientCapabilities
325 didChangeCaps = def { _workspace = Just workspaceCaps }
327 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
328 configCaps = DidChangeConfigurationClientCapabilities (Just True)
330 docChangesCaps :: ClientCapabilities
331 docChangesCaps = def { _workspace = Just workspaceCaps }
333 workspaceCaps = def { _workspaceEdit = Just editCaps }
334 editCaps = WorkspaceEditClientCapabilities (Just True)
336 data ApplyOneParams = AOP
338 , start_pos :: Position
339 , hintTitle :: String
340 } deriving (Generic, ToJSON)