1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
9 import qualified Data.HashMap.Strict as HM
11 import Data.List (sortOn)
13 import qualified Data.Text as T
14 import Control.Applicative.Combinators
15 import Control.Concurrent
16 import Control.Exception (finally)
17 import Control.Monad.IO.Class
19 import Control.Lens hiding (List)
20 import Language.Haskell.LSP.Messages
21 import Language.Haskell.LSP.Test
22 import Language.Haskell.LSP.Types
23 import Language.Haskell.LSP.Types.Lens hiding
24 (capabilities, message, rename, applyEdit)
25 import qualified Language.Haskell.LSP.Types.Lens as LSP
26 import Language.Haskell.LSP.Types.Capabilities as LSP
27 import System.Directory
28 import System.FilePath
31 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
32 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
35 main = findServer >>= \serverExe -> hspec $ do
36 describe "Session" $ do
37 it "fails a test" $ do
38 let session = runSession serverExe fullCaps "test/data/renamePass" $ do
39 openDoc "Desktop/simple.hs" "haskell"
41 in session `shouldThrow` anySessionException
42 it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do
43 rsp <- initializeResponse
44 liftIO $ rsp ^. result `shouldSatisfy` isRight
46 it "runSessionWithConfig" $
47 runSession serverExe didChangeCaps "test/data/renamePass" $ return ()
49 describe "withTimeout" $ do
51 let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
52 openDoc "Desktop/simple.hs" "haskell"
53 -- won't receive a request - will timeout
54 -- incoming logging requests shouldn't increase the
56 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
57 -- wait just a bit longer than 5 seconds so we have time
58 -- to open the document
59 in timeout 6000000 sesh `shouldThrow` anySessionException
61 it "doesn't time out" $
62 let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
63 openDoc "Desktop/simple.hs" "haskell"
64 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
65 in void $ timeout 6000000 sesh
67 it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do
68 doc <- openDoc "Desktop/simple.hs" "haskell"
70 withTimeout 3 $ getDocumentSymbols doc
71 -- longer than the original timeout
72 liftIO $ threadDelay (5 * 10^6)
73 -- shouldn't throw an exception
74 getDocumentSymbols doc
77 it "overrides global message timeout" $
79 runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
80 doc <- openDoc "Desktop/simple.hs" "haskell"
81 -- shouldn't time out in here since we are overriding it
82 withTimeout 10 $ liftIO $ threadDelay 7000000
83 getDocumentSymbols doc
85 in sesh `shouldReturn` True
87 it "unoverrides global message timeout" $
89 runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
90 doc <- openDoc "Desktop/simple.hs" "haskell"
91 -- shouldn't time out in here since we are overriding it
92 withTimeout 10 $ liftIO $ threadDelay 7000000
93 getDocumentSymbols doc
95 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
96 isTimeout (Timeout _) = True
98 in sesh `shouldThrow` isTimeout
101 describe "SessionException" $ do
102 it "throw on time out" $
103 let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do
104 skipMany loggingNotification
105 _ <- message :: Session ApplyWorkspaceEditRequest
107 in sesh `shouldThrow` anySessionException
109 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do
111 liftIO $ threadDelay $ 6 * 1000000
112 _ <- openDoc "Desktop/simple.hs" "haskell"
115 describe "UnexpectedMessageException" $ do
116 it "throws when there's an unexpected message" $
117 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
119 in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
120 it "provides the correct types that were expected and received" $
121 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
124 doc <- openDoc "Desktop/simple.hs" "haskell"
125 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
126 skipMany anyNotification
127 message :: Session RenameResponse -- the wrong type
128 in runSession serverExe fullCaps "test/data/renamePass" sesh
129 `shouldThrow` selector
131 -- This is too fickle at the moment
132 -- describe "replaySession" $
133 -- it "passes a test" $
134 -- replaySession serverExe "test/data/renamePass"
135 -- it "fails a test" $
136 -- let selector (ReplayOutOfOrder _ _) = True
137 -- selector _ = False
138 -- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector
140 -- describe "manual javascript session" $
141 -- it "passes a test" $
142 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
143 -- doc <- openDoc "test.js" "javascript"
147 -- Right (fooSymbol:_) <- getDocumentSymbols doc
150 -- fooSymbol ^. name `shouldBe` "foo"
151 -- fooSymbol ^. kind `shouldBe` SkFunction
153 describe "text document VFS" $
154 it "sends back didChange notifications" $
155 runSession serverExe def "test/data/refactor" $ do
156 doc <- openDoc "Main.hs" "haskell"
158 let args = toJSON (doc ^. uri)
159 reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
160 request_ WorkspaceExecuteCommand reqParams
162 editReq <- message :: Session ApplyWorkspaceEditRequest
164 let (Just cs) = editReq ^. params . edit . changes
165 [(u, List es)] = HM.toList cs
166 u `shouldBe` doc ^. uri
167 es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
168 contents <- documentContents doc
169 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
171 describe "getDocumentEdit" $
172 it "automatically consumes applyedit requests" $
173 runSession serverExe fullCaps "test/data/refactor" $ do
174 doc <- openDoc "Main.hs" "haskell"
176 let args = toJSON (doc ^. uri)
177 reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
178 request_ WorkspaceExecuteCommand reqParams
179 contents <- getDocumentEdit doc
180 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
182 describe "getCodeActions" $
183 it "works" $ runSession serverExe 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` "Delete this"
189 describe "getAllCodeActions" $
190 it "works" $ runSession serverExe 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` "Delete this"
197 action ^. command . _Just . command `shouldBe` "deleteThis"
199 describe "getDocumentSymbols" $
200 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
201 doc <- openDoc "Desktop/simple.hs" "haskell"
203 skipMany loggingNotification
205 Left (mainSymbol:_) <- getDocumentSymbols doc
208 mainSymbol ^. name `shouldBe` "foo"
209 mainSymbol ^. kind `shouldBe` SkObject
210 mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
212 describe "applyEdit" $ do
213 it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
214 doc <- openDoc "Desktop/simple.hs" "haskell"
215 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
216 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
217 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
218 liftIO $ newVersion `shouldBe` oldVersion + 1
219 it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
220 doc <- openDoc "Desktop/simple.hs" "haskell"
221 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
223 contents <- documentContents doc
224 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
226 -- describe "getCompletions" $
227 -- it "works" $ runSession serverExe def "test/data/renamePass" $ do
228 -- doc <- openDoc "Desktop/simple.hs" "haskell"
230 -- -- wait for module to be loaded
231 -- skipMany loggingNotification
235 -- comps <- getCompletions doc (Position 5 5)
236 -- let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
238 -- item ^. label `shouldBe` "interactWithUser"
239 -- item ^. kind `shouldBe` Just CiFunction
240 -- item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
242 -- describe "getReferences" $
243 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
244 -- doc <- openDoc "Desktop/simple.hs" "haskell"
245 -- let pos = Position 40 3 -- interactWithUser
246 -- uri = doc ^. LSP.uri
247 -- refs <- getReferences doc pos True
248 -- liftIO $ refs `shouldContain` map (Location uri) [
249 -- mkRange 41 0 41 16
250 -- , mkRange 75 6 75 22
251 -- , mkRange 71 6 71 22
254 -- describe "getDefinitions" $
255 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
256 -- doc <- openDoc "Desktop/simple.hs" "haskell"
257 -- let pos = Position 49 25 -- addItem
258 -- defs <- getDefinitions doc pos
259 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
261 -- describe "getTypeDefinitions" $
262 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
263 -- doc <- openDoc "Desktop/simple.hs" "haskell"
264 -- let pos = Position 20 23 -- Quit value
265 -- defs <- getTypeDefinitions doc pos
266 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
268 describe "waitForDiagnosticsSource" $
269 it "works" $ runSession serverExe fullCaps "test/data" $ do
270 openDoc "Error.hs" "haskell"
271 [diag] <- waitForDiagnosticsSource "dummy-server"
273 diag ^. severity `shouldBe` Just DsWarning
274 diag ^. source `shouldBe` Just "dummy-server"
276 -- describe "rename" $ do
277 -- it "works" $ pendingWith "HaRe not in hie-bios yet"
278 -- it "works on javascript" $
279 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
280 -- doc <- openDoc "test.js" "javascript"
281 -- rename doc (Position 2 11) "bar"
282 -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
284 describe "getHover" $
285 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
286 doc <- openDoc "Desktop/simple.hs" "haskell"
287 hover <- getHover doc (Position 45 9)
288 liftIO $ hover `shouldSatisfy` isJust
290 -- describe "getHighlights" $
291 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
292 -- doc <- openDoc "Desktop/simple.hs" "haskell"
293 -- skipManyTill loggingNotification $ count 2 noDiagnostics
294 -- highlights <- getHighlights doc (Position 27 4) -- addItem
295 -- liftIO $ length highlights `shouldBe` 4
297 -- describe "formatDoc" $
298 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
299 -- doc <- openDoc "Format.hs" "haskell"
300 -- oldContents <- documentContents doc
301 -- formatDoc doc (FormattingOptions 4 True)
302 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
304 -- describe "formatRange" $
305 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
306 -- doc <- openDoc "Format.hs" "haskell"
307 -- oldContents <- documentContents doc
308 -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
309 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
311 describe "closeDoc" $
314 runSession serverExe fullCaps "test/data" $ do
315 doc <- openDoc "Format.hs" "haskell"
317 -- need to evaluate to throw
318 documentContents doc >>= liftIO . print
319 in sesh `shouldThrow` anyException
322 it "works" $ runSession serverExe fullCaps "test/data" $ do
323 openDoc "Format.hs" "haskell"
324 let pred (NotLogMessage _) = True
328 describe "ignoreLogNotifications" $
330 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do
331 openDoc "Format.hs" "haskell"
332 void publishDiagnosticsNotification
334 describe "dynamic capabilities" $ do
335 it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
336 loggingNotification -- initialized log message
338 createDoc ".register" "haskell" ""
339 message :: Session RegisterCapabilityRequest
341 doc <- createDoc "Foo.watch" "haskell" ""
342 NotLogMessage msg <- loggingNotification
343 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
345 caps <- getRegisteredCapabilities
346 liftIO $ caps `shouldBe`
347 [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
348 DidChangeWatchedFilesRegistrationOptions $ List
349 [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
352 -- now unregister it by sending a specific createDoc
353 createDoc ".unregister" "haskell" ""
354 message :: Session UnregisterCapabilityRequest
356 createDoc "Bar.watch" "haskell" ""
357 void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
358 count 0 $ loggingNotification
361 it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
362 curDir <- liftIO $ getCurrentDirectory
364 loggingNotification -- initialized log message
366 createDoc ".register.abs" "haskell" ""
367 message :: Session RegisterCapabilityRequest
369 doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
370 NotLogMessage msg <- loggingNotification
371 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
373 -- now unregister it by sending a specific createDoc
374 createDoc ".unregister.abs" "haskell" ""
375 message :: Session UnregisterCapabilityRequest
377 createDoc (curDir </> "Bar.watch") "haskell" ""
378 void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
379 count 0 $ loggingNotification
382 describe "file watching" $
384 tmp <- liftIO getTemporaryDirectory
385 let testFile = tmp </> "lsp-test.watch"
386 testFile' = tmp </> "lsp-test.nowatch"
387 finally (runSession serverExe fullCaps "" $ do
388 loggingNotification -- initialized log message
390 createDoc ".register.tmp" "haskell" ""
391 message :: Session RegisterCapabilityRequest
393 liftIO $ writeFile testFile "Hello" -- >> hFlush h
394 NotLogMessage msg <- loggingNotification
395 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
397 -- this shouldn't trigger a watch files thingy
398 liftIO $ writeFile testFile' "Hello"
399 doc <- createDoc "blah" "haskell" ""
402 void $ sendRequest TextDocumentHover $
403 TextDocumentPositionParams doc (Position 0 0) Nothing
404 count 0 $ loggingNotification
408 -- unwatch .watch in tmp
409 createDoc ".unregister.tmp" "haskell" ""
410 message :: Session UnregisterCapabilityRequest
412 -- modifying shouldn't return anything
413 liftIO $ writeFile testFile "Hello"
414 testNoLog) (mapM_ removeFile [testFile, testFile'])
417 mkRange :: Int -> Int -> Int -> Int -> Range
418 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
420 didChangeCaps :: ClientCapabilities
421 didChangeCaps = def { _workspace = Just workspaceCaps }
423 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
424 configCaps = DidChangeConfigurationClientCapabilities (Just True)
426 docChangesCaps :: ClientCapabilities
427 docChangesCaps = def { _workspace = Just workspaceCaps }
429 workspaceCaps = def { _workspaceEdit = Just editCaps }
430 editCaps = WorkspaceEditClientCapabilities (Just True)
433 findExeRecursive :: FilePath -> FilePath -> IO [FilePath]
434 findExeRecursive exe dir = do
435 exes <- findExecutablesInDirectories [dir] exe
436 subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
437 exes' <- concat <$> mapM (findExeRecursive exe) subdirs
438 return $ exes ++ exes'
440 newestExe :: [FilePath] -> IO (Maybe FilePath)
442 pairs <- zip exes <$> mapM getModificationTime exes
443 case sortOn snd pairs of
444 (e,_):_ -> return $ Just e
447 -- | So we can find the dummy-server with cabal run
448 -- since it doesnt put build tools on the path (only cabal test)
450 let serverName = "dummy-server"
451 e <- findExecutable serverName
452 e' <- findExeRecursive serverName "dist-newstyle" >>= newestExe
453 pure $ fromJust $ e <|> e'