1 {-# LANGUAGE TypeInType #-}
3 {-# LANGUAGE DuplicateRecordFields #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE DeriveGeneric #-}
6 {-# LANGUAGE DeriveAnyClass #-}
11 import qualified Data.HashMap.Strict as HM
14 import qualified Data.Text as T
15 import Control.Applicative.Combinators
16 import Control.Concurrent
17 import Control.Monad.IO.Class
19 import Control.Lens hiding (List)
20 import Language.LSP.Test
21 import Language.LSP.Types
22 import Language.LSP.Types.Lens hiding
23 (capabilities, message, rename, applyEdit)
24 import qualified Language.LSP.Types.Lens as LSP
25 import Language.LSP.Types.Capabilities as LSP
26 import System.Directory
27 import System.FilePath
29 import Data.Type.Equality
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 SWorkspaceApplyEdit)
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 SWorkspaceApplyEdit)
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 SWorkspaceApplyEdit
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" (FromServerMess SWindowLogMessage _)) = 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 "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
124 doc <- openDoc "Desktop/simple.hs" "haskell"
125 sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
126 skipMany anyNotification
127 response STextDocumentRename -- the wrong type
128 in runSession serverExe fullCaps "test/data/renamePass" sesh
129 `shouldThrow` selector
131 describe "text document VFS" $
132 it "sends back didChange notifications" $
133 runSession serverExe def "test/data/refactor" $ do
134 doc <- openDoc "Main.hs" "haskell"
136 let args = toJSON (doc ^. uri)
137 reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
138 request_ SWorkspaceExecuteCommand reqParams
140 editReq <- message SWorkspaceApplyEdit
142 let (Just cs) = editReq ^. params . edit . changes
143 [(u, List es)] = HM.toList cs
144 u `shouldBe` doc ^. uri
145 es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
146 contents <- documentContents doc
147 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
149 describe "getDocumentEdit" $
150 it "automatically consumes applyedit requests" $
151 runSession serverExe fullCaps "test/data/refactor" $ do
152 doc <- openDoc "Main.hs" "haskell"
154 let args = toJSON (doc ^. uri)
155 reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
156 request_ SWorkspaceExecuteCommand reqParams
157 contents <- getDocumentEdit doc
158 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
160 describe "getCodeActions" $
161 it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
162 doc <- openDoc "Main.hs" "haskell"
164 [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2))
165 actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
166 liftIO $ action ^. title `shouldBe` "Delete this"
167 liftIO $ actions `shouldSatisfy` null
169 describe "getAllCodeActions" $
170 it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
171 doc <- openDoc "Main.hs" "haskell"
172 _ <- waitForDiagnostics
173 actions <- getAllCodeActions doc
175 let [InR action] = actions
176 action ^. title `shouldBe` "Delete this"
177 action ^. command . _Just . command `shouldBe` "deleteThis"
179 describe "getDocumentSymbols" $
180 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
181 doc <- openDoc "Desktop/simple.hs" "haskell"
183 skipMany loggingNotification
185 Left (mainSymbol:_) <- getDocumentSymbols doc
188 mainSymbol ^. name `shouldBe` "foo"
189 mainSymbol ^. kind `shouldBe` SkObject
190 mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
192 describe "applyEdit" $ do
193 it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
194 doc <- openDoc "Desktop/simple.hs" "haskell"
195 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
196 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
197 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
198 liftIO $ newVersion `shouldBe` oldVersion + 1
199 it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
200 doc <- openDoc "Desktop/simple.hs" "haskell"
201 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
203 contents <- documentContents doc
204 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
206 describe "getCompletions" $
207 it "works" $ runSession serverExe def "test/data/renamePass" $ do
208 doc <- openDoc "Desktop/simple.hs" "haskell"
210 comps <- getCompletions doc (Position 5 5)
211 let item = head comps
212 liftIO $ item ^. label `shouldBe` "foo"
214 -- describe "getReferences" $
215 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
216 -- doc <- openDoc "Desktop/simple.hs" "haskell"
217 -- let pos = Position 40 3 -- interactWithUser
218 -- uri = doc ^. LSP.uri
219 -- refs <- getReferences doc pos True
220 -- liftIO $ refs `shouldContain` map (Location uri) [
221 -- mkRange 41 0 41 16
222 -- , mkRange 75 6 75 22
223 -- , mkRange 71 6 71 22
226 -- describe "getDefinitions" $
227 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
228 -- doc <- openDoc "Desktop/simple.hs" "haskell"
229 -- let pos = Position 49 25 -- addItem
230 -- defs <- getDefinitions doc pos
231 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
233 -- describe "getTypeDefinitions" $
234 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
235 -- doc <- openDoc "Desktop/simple.hs" "haskell"
236 -- let pos = Position 20 23 -- Quit value
237 -- defs <- getTypeDefinitions doc pos
238 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
240 describe "waitForDiagnosticsSource" $
241 it "works" $ runSession serverExe fullCaps "test/data" $ do
242 openDoc "Error.hs" "haskell"
243 [diag] <- waitForDiagnosticsSource "dummy-server"
245 diag ^. severity `shouldBe` Just DsWarning
246 diag ^. source `shouldBe` Just "dummy-server"
248 -- describe "rename" $ do
249 -- it "works" $ pendingWith "HaRe not in hie-bios yet"
250 -- it "works on javascript" $
251 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
252 -- doc <- openDoc "test.js" "javascript"
253 -- rename doc (Position 2 11) "bar"
254 -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
256 describe "getHover" $
257 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
258 doc <- openDoc "Desktop/simple.hs" "haskell"
259 hover <- getHover doc (Position 45 9)
260 liftIO $ hover `shouldSatisfy` isJust
262 -- describe "getHighlights" $
263 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
264 -- doc <- openDoc "Desktop/simple.hs" "haskell"
265 -- skipManyTill loggingNotification $ count 2 noDiagnostics
266 -- highlights <- getHighlights doc (Position 27 4) -- addItem
267 -- liftIO $ length highlights `shouldBe` 4
269 -- describe "formatDoc" $
270 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
271 -- doc <- openDoc "Format.hs" "haskell"
272 -- oldContents <- documentContents doc
273 -- formatDoc doc (FormattingOptions 4 True)
274 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
276 -- describe "formatRange" $
277 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
278 -- doc <- openDoc "Format.hs" "haskell"
279 -- oldContents <- documentContents doc
280 -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
281 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
283 describe "closeDoc" $
286 runSession serverExe fullCaps "test/data" $ do
287 doc <- openDoc "Format.hs" "haskell"
289 -- need to evaluate to throw
290 documentContents doc >>= liftIO . print
291 in sesh `shouldThrow` anyException
294 it "works" $ runSession serverExe fullCaps "test/data" $ do
295 openDoc "Format.hs" "haskell"
296 let pred (FromServerMess SWindowLogMessage _) = True
300 describe "ignoreLogNotifications" $
302 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do
303 openDoc "Format.hs" "haskell"
304 void publishDiagnosticsNotification
306 describe "dynamic capabilities" $ do
308 it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
309 loggingNotification -- initialized log message
311 createDoc ".register" "haskell" ""
312 message SClientRegisterCapability
314 doc <- createDoc "Foo.watch" "haskell" ""
315 msg <- message SWindowLogMessage
316 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
318 [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities
320 case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of
322 regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List
323 [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])
324 Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"
326 -- now unregister it by sending a specific createDoc
327 createDoc ".unregister" "haskell" ""
328 message SClientUnregisterCapability
330 createDoc "Bar.watch" "haskell" ""
331 void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
332 count 0 $ loggingNotification
335 it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
336 curDir <- liftIO $ getCurrentDirectory
338 loggingNotification -- initialized log message
340 createDoc ".register.abs" "haskell" ""
341 message SClientRegisterCapability
343 doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
344 msg <- message SWindowLogMessage
345 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
347 -- now unregister it by sending a specific createDoc
348 createDoc ".unregister.abs" "haskell" ""
349 message SClientUnregisterCapability
351 createDoc (curDir </> "Bar.watch") "haskell" ""
352 void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
353 count 0 $ loggingNotification
357 didChangeCaps :: ClientCapabilities
358 didChangeCaps = def { _workspace = Just workspaceCaps }
360 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
361 configCaps = DidChangeConfigurationClientCapabilities (Just True)
363 docChangesCaps :: ClientCapabilities
364 docChangesCaps = def { _workspace = Just workspaceCaps }
366 workspaceCaps = def { _workspaceEdit = Just editCaps }
367 editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing
370 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
371 findExeRecursive exe dir = do
372 me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
374 Just e -> return (Just e)
376 subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
377 foldM (\acc subdir -> case acc of
378 Just y -> pure $ Just y
379 Nothing -> findExeRecursive exe subdir)
383 -- | So we can find the dummy-server with cabal run
384 -- since it doesnt put build tools on the path (only cabal test)
386 let serverName = "dummy-server"
387 e <- findExecutable serverName
388 e' <- findExeRecursive serverName "dist-newstyle"
389 pure $ fromJust $ e <|> e'