1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
9 import qualified Data.HashMap.Strict as HM
12 import qualified Data.Text as T
13 import Control.Applicative.Combinators
14 import Control.Concurrent
15 import Control.Monad.IO.Class
17 import Control.Lens hiding (List)
18 import Language.Haskell.LSP.Messages
19 import Language.Haskell.LSP.Test
20 import Language.Haskell.LSP.Types
21 import Language.Haskell.LSP.Types.Lens hiding
22 (capabilities, message, rename, applyEdit)
23 import qualified Language.Haskell.LSP.Types.Lens as LSP
24 import Language.Haskell.LSP.Types.Capabilities as LSP
25 import System.Directory
26 import System.FilePath
29 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
30 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
33 main = findServer >>= \serverExe -> hspec $ do
34 describe "Session" $ do
35 it "fails a test" $ do
36 let session = runSession serverExe fullCaps "test/data/renamePass" $ do
37 openDoc "Desktop/simple.hs" "haskell"
39 in session `shouldThrow` anySessionException
40 it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do
41 rsp <- initializeResponse
42 liftIO $ rsp ^. result `shouldSatisfy` isRight
44 it "runSessionWithConfig" $
45 runSession serverExe didChangeCaps "test/data/renamePass" $ return ()
47 describe "withTimeout" $ do
49 let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
50 openDoc "Desktop/simple.hs" "haskell"
51 -- won't receive a request - will timeout
52 -- incoming logging requests shouldn't increase the
54 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
55 -- wait just a bit longer than 5 seconds so we have time
56 -- to open the document
57 in timeout 6000000 sesh `shouldThrow` anySessionException
59 it "doesn't time out" $
60 let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
61 openDoc "Desktop/simple.hs" "haskell"
62 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
63 in void $ timeout 6000000 sesh
65 it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do
66 doc <- openDoc "Desktop/simple.hs" "haskell"
68 withTimeout 3 $ getDocumentSymbols doc
69 -- longer than the original timeout
70 liftIO $ threadDelay (5 * 10^6)
71 -- shouldn't throw an exception
72 getDocumentSymbols doc
75 it "overrides global message timeout" $
77 runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
78 doc <- openDoc "Desktop/simple.hs" "haskell"
79 -- shouldn't time out in here since we are overriding it
80 withTimeout 10 $ liftIO $ threadDelay 7000000
81 getDocumentSymbols doc
83 in sesh `shouldReturn` True
85 it "unoverrides global message timeout" $
87 runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
88 doc <- openDoc "Desktop/simple.hs" "haskell"
89 -- shouldn't time out in here since we are overriding it
90 withTimeout 10 $ liftIO $ threadDelay 7000000
91 getDocumentSymbols doc
93 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
94 isTimeout (Timeout _) = True
96 in sesh `shouldThrow` isTimeout
99 describe "SessionException" $ do
100 it "throw on time out" $
101 let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do
102 skipMany loggingNotification
103 _ <- message :: Session ApplyWorkspaceEditRequest
105 in sesh `shouldThrow` anySessionException
107 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do
109 liftIO $ threadDelay $ 6 * 1000000
110 _ <- openDoc "Desktop/simple.hs" "haskell"
113 describe "UnexpectedMessageException" $ do
114 it "throws when there's an unexpected message" $
115 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
117 in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
118 it "provides the correct types that were expected and received" $
119 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
122 doc <- openDoc "Desktop/simple.hs" "haskell"
123 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
124 skipMany anyNotification
125 message :: Session RenameResponse -- the wrong type
126 in runSession serverExe fullCaps "test/data/renamePass" sesh
127 `shouldThrow` selector
129 -- This is too fickle at the moment
130 -- describe "replaySession" $
131 -- it "passes a test" $
132 -- replaySession serverExe "test/data/renamePass"
133 -- it "fails a test" $
134 -- let selector (ReplayOutOfOrder _ _) = True
135 -- selector _ = False
136 -- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector
138 -- describe "manual javascript session" $
139 -- it "passes a test" $
140 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
141 -- doc <- openDoc "test.js" "javascript"
145 -- Right (fooSymbol:_) <- getDocumentSymbols doc
148 -- fooSymbol ^. name `shouldBe` "foo"
149 -- fooSymbol ^. kind `shouldBe` SkFunction
151 describe "text document VFS" $
152 it "sends back didChange notifications" $
153 runSession serverExe def "test/data/refactor" $ do
154 doc <- openDoc "Main.hs" "haskell"
156 let args = toJSON (doc ^. uri)
157 reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
158 request_ WorkspaceExecuteCommand reqParams
160 editReq <- message :: Session ApplyWorkspaceEditRequest
162 let (Just cs) = editReq ^. params . edit . changes
163 [(u, List es)] = HM.toList cs
164 u `shouldBe` doc ^. uri
165 es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
166 contents <- documentContents doc
167 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
169 describe "getDocumentEdit" $
170 it "automatically consumes applyedit requests" $
171 runSession serverExe fullCaps "test/data/refactor" $ do
172 doc <- openDoc "Main.hs" "haskell"
174 let args = toJSON (doc ^. uri)
175 reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
176 request_ WorkspaceExecuteCommand reqParams
177 contents <- getDocumentEdit doc
178 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
180 describe "getCodeActions" $
181 it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
182 doc <- openDoc "Main.hs" "haskell"
184 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
185 liftIO $ action ^. title `shouldBe` "Delete this"
187 describe "getAllCodeActions" $
188 it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
189 doc <- openDoc "Main.hs" "haskell"
190 _ <- waitForDiagnostics
191 actions <- getAllCodeActions doc
193 let [CACodeAction action] = actions
194 action ^. title `shouldBe` "Delete this"
195 action ^. command . _Just . command `shouldBe` "deleteThis"
197 describe "getDocumentSymbols" $
198 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
199 doc <- openDoc "Desktop/simple.hs" "haskell"
201 skipMany loggingNotification
203 Left (mainSymbol:_) <- getDocumentSymbols doc
206 mainSymbol ^. name `shouldBe` "foo"
207 mainSymbol ^. kind `shouldBe` SkObject
208 mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
210 describe "applyEdit" $ do
211 it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
212 doc <- openDoc "Desktop/simple.hs" "haskell"
213 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
214 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
215 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
216 liftIO $ newVersion `shouldBe` oldVersion + 1
217 it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
218 doc <- openDoc "Desktop/simple.hs" "haskell"
219 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
221 contents <- documentContents doc
222 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
224 describe "getCompletions" $
225 it "works" $ runSession serverExe def "test/data/renamePass" $ do
226 doc <- openDoc "Desktop/simple.hs" "haskell"
228 comps <- getCompletions doc (Position 5 5)
229 let item = head comps
230 liftIO $ item ^. label `shouldBe` "foo"
232 -- describe "getReferences" $
233 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
234 -- doc <- openDoc "Desktop/simple.hs" "haskell"
235 -- let pos = Position 40 3 -- interactWithUser
236 -- uri = doc ^. LSP.uri
237 -- refs <- getReferences doc pos True
238 -- liftIO $ refs `shouldContain` map (Location uri) [
239 -- mkRange 41 0 41 16
240 -- , mkRange 75 6 75 22
241 -- , mkRange 71 6 71 22
244 -- describe "getDefinitions" $
245 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
246 -- doc <- openDoc "Desktop/simple.hs" "haskell"
247 -- let pos = Position 49 25 -- addItem
248 -- defs <- getDefinitions doc pos
249 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
251 -- describe "getTypeDefinitions" $
252 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
253 -- doc <- openDoc "Desktop/simple.hs" "haskell"
254 -- let pos = Position 20 23 -- Quit value
255 -- defs <- getTypeDefinitions doc pos
256 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
258 describe "waitForDiagnosticsSource" $
259 it "works" $ runSession serverExe fullCaps "test/data" $ do
260 openDoc "Error.hs" "haskell"
261 [diag] <- waitForDiagnosticsSource "dummy-server"
263 diag ^. severity `shouldBe` Just DsWarning
264 diag ^. source `shouldBe` Just "dummy-server"
266 -- describe "rename" $ do
267 -- it "works" $ pendingWith "HaRe not in hie-bios yet"
268 -- it "works on javascript" $
269 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
270 -- doc <- openDoc "test.js" "javascript"
271 -- rename doc (Position 2 11) "bar"
272 -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
274 describe "getHover" $
275 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
276 doc <- openDoc "Desktop/simple.hs" "haskell"
277 hover <- getHover doc (Position 45 9)
278 liftIO $ hover `shouldSatisfy` isJust
280 -- describe "getHighlights" $
281 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
282 -- doc <- openDoc "Desktop/simple.hs" "haskell"
283 -- skipManyTill loggingNotification $ count 2 noDiagnostics
284 -- highlights <- getHighlights doc (Position 27 4) -- addItem
285 -- liftIO $ length highlights `shouldBe` 4
287 -- describe "formatDoc" $
288 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
289 -- doc <- openDoc "Format.hs" "haskell"
290 -- oldContents <- documentContents doc
291 -- formatDoc doc (FormattingOptions 4 True)
292 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
294 -- describe "formatRange" $
295 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
296 -- doc <- openDoc "Format.hs" "haskell"
297 -- oldContents <- documentContents doc
298 -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
299 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
301 describe "closeDoc" $
304 runSession serverExe fullCaps "test/data" $ do
305 doc <- openDoc "Format.hs" "haskell"
307 -- need to evaluate to throw
308 documentContents doc >>= liftIO . print
309 in sesh `shouldThrow` anyException
312 it "works" $ runSession serverExe fullCaps "test/data" $ do
313 openDoc "Format.hs" "haskell"
314 let pred (NotLogMessage _) = True
318 describe "ignoreLogNotifications" $
320 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do
321 openDoc "Format.hs" "haskell"
322 void publishDiagnosticsNotification
324 describe "dynamic capabilities" $ do
325 it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
326 loggingNotification -- initialized log message
328 createDoc ".register" "haskell" ""
329 message :: Session RegisterCapabilityRequest
331 doc <- createDoc "Foo.watch" "haskell" ""
332 NotLogMessage msg <- loggingNotification
333 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
335 caps <- getRegisteredCapabilities
336 liftIO $ caps `shouldBe`
337 [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
338 DidChangeWatchedFilesRegistrationOptions $ List
339 [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
342 -- now unregister it by sending a specific createDoc
343 createDoc ".unregister" "haskell" ""
344 message :: Session UnregisterCapabilityRequest
346 createDoc "Bar.watch" "haskell" ""
347 void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
348 count 0 $ loggingNotification
351 it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
352 curDir <- liftIO $ getCurrentDirectory
354 loggingNotification -- initialized log message
356 createDoc ".register.abs" "haskell" ""
357 message :: Session RegisterCapabilityRequest
359 doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
360 NotLogMessage msg <- loggingNotification
361 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
363 -- now unregister it by sending a specific createDoc
364 createDoc ".unregister.abs" "haskell" ""
365 message :: Session UnregisterCapabilityRequest
367 createDoc (curDir </> "Bar.watch") "haskell" ""
368 void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
369 count 0 $ loggingNotification
373 mkRange :: Int -> Int -> Int -> Int -> Range
374 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
376 didChangeCaps :: ClientCapabilities
377 didChangeCaps = def { _workspace = Just workspaceCaps }
379 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
380 configCaps = DidChangeConfigurationClientCapabilities (Just True)
382 docChangesCaps :: ClientCapabilities
383 docChangesCaps = def { _workspace = Just workspaceCaps }
385 workspaceCaps = def { _workspaceEdit = Just editCaps }
386 editCaps = WorkspaceEditClientCapabilities (Just True)
389 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
390 findExeRecursive exe dir = do
391 me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
393 Just e -> return (Just e)
395 subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
396 foldM (\acc subdir -> case acc of
397 Just y -> pure $ Just y
398 Nothing -> findExeRecursive exe subdir)
402 -- | So we can find the dummy-server with cabal run
403 -- since it doesnt put build tools on the path (only cabal test)
405 let serverName = "dummy-server"
406 e <- findExecutable serverName
407 e' <- findExeRecursive serverName "dist-newstyle"
408 pure $ fromJust $ e <|> e'