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 "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 1 14) (Position 1 18))
165 liftIO $ action ^. title `shouldBe` "Delete this"
167 describe "getAllCodeActions" $
168 it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
169 doc <- openDoc "Main.hs" "haskell"
170 _ <- waitForDiagnostics
171 actions <- getAllCodeActions doc
173 let [InR action] = actions
174 action ^. title `shouldBe` "Delete this"
175 action ^. command . _Just . command `shouldBe` "deleteThis"
177 describe "getDocumentSymbols" $
178 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
179 doc <- openDoc "Desktop/simple.hs" "haskell"
181 skipMany loggingNotification
183 Left (mainSymbol:_) <- getDocumentSymbols doc
186 mainSymbol ^. name `shouldBe` "foo"
187 mainSymbol ^. kind `shouldBe` SkObject
188 mainSymbol ^. range `shouldBe` mkRange 0 0 3 6
190 describe "applyEdit" $ do
191 it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
192 doc <- openDoc "Desktop/simple.hs" "haskell"
193 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
194 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
195 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
196 liftIO $ newVersion `shouldBe` oldVersion + 1
197 it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
198 doc <- openDoc "Desktop/simple.hs" "haskell"
199 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
201 contents <- documentContents doc
202 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
204 describe "getCompletions" $
205 it "works" $ runSession serverExe def "test/data/renamePass" $ do
206 doc <- openDoc "Desktop/simple.hs" "haskell"
208 comps <- getCompletions doc (Position 5 5)
209 let item = head comps
210 liftIO $ item ^. label `shouldBe` "foo"
212 -- describe "getReferences" $
213 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
214 -- doc <- openDoc "Desktop/simple.hs" "haskell"
215 -- let pos = Position 40 3 -- interactWithUser
216 -- uri = doc ^. LSP.uri
217 -- refs <- getReferences doc pos True
218 -- liftIO $ refs `shouldContain` map (Location uri) [
219 -- mkRange 41 0 41 16
220 -- , mkRange 75 6 75 22
221 -- , mkRange 71 6 71 22
224 -- describe "getDefinitions" $
225 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
226 -- doc <- openDoc "Desktop/simple.hs" "haskell"
227 -- let pos = Position 49 25 -- addItem
228 -- defs <- getDefinitions doc pos
229 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
231 -- describe "getTypeDefinitions" $
232 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
233 -- doc <- openDoc "Desktop/simple.hs" "haskell"
234 -- let pos = Position 20 23 -- Quit value
235 -- defs <- getTypeDefinitions doc pos
236 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
238 describe "waitForDiagnosticsSource" $
239 it "works" $ runSession serverExe fullCaps "test/data" $ do
240 openDoc "Error.hs" "haskell"
241 [diag] <- waitForDiagnosticsSource "dummy-server"
243 diag ^. severity `shouldBe` Just DsWarning
244 diag ^. source `shouldBe` Just "dummy-server"
246 -- describe "rename" $ do
247 -- it "works" $ pendingWith "HaRe not in hie-bios yet"
248 -- it "works on javascript" $
249 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
250 -- doc <- openDoc "test.js" "javascript"
251 -- rename doc (Position 2 11) "bar"
252 -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
254 describe "getHover" $
255 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
256 doc <- openDoc "Desktop/simple.hs" "haskell"
257 hover <- getHover doc (Position 45 9)
258 liftIO $ hover `shouldSatisfy` isJust
260 -- describe "getHighlights" $
261 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
262 -- doc <- openDoc "Desktop/simple.hs" "haskell"
263 -- skipManyTill loggingNotification $ count 2 noDiagnostics
264 -- highlights <- getHighlights doc (Position 27 4) -- addItem
265 -- liftIO $ length highlights `shouldBe` 4
267 -- describe "formatDoc" $
268 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
269 -- doc <- openDoc "Format.hs" "haskell"
270 -- oldContents <- documentContents doc
271 -- formatDoc doc (FormattingOptions 4 True)
272 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
274 -- describe "formatRange" $
275 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
276 -- doc <- openDoc "Format.hs" "haskell"
277 -- oldContents <- documentContents doc
278 -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
279 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
281 describe "closeDoc" $
284 runSession serverExe fullCaps "test/data" $ do
285 doc <- openDoc "Format.hs" "haskell"
287 -- need to evaluate to throw
288 documentContents doc >>= liftIO . print
289 in sesh `shouldThrow` anyException
292 it "works" $ runSession serverExe fullCaps "test/data" $ do
293 openDoc "Format.hs" "haskell"
294 let pred (FromServerMess SWindowLogMessage _) = True
298 describe "ignoreLogNotifications" $
300 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do
301 openDoc "Format.hs" "haskell"
302 void publishDiagnosticsNotification
304 describe "dynamic capabilities" $ do
306 it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
307 loggingNotification -- initialized log message
309 createDoc ".register" "haskell" ""
310 message SClientRegisterCapability
312 doc <- createDoc "Foo.watch" "haskell" ""
313 msg <- message SWindowLogMessage
314 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
316 [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities
318 case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of
320 regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List
321 [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])
322 Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"
324 -- now unregister it by sending a specific createDoc
325 createDoc ".unregister" "haskell" ""
326 message SClientUnregisterCapability
328 createDoc "Bar.watch" "haskell" ""
329 void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
330 count 0 $ loggingNotification
333 it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do
334 curDir <- liftIO $ getCurrentDirectory
336 loggingNotification -- initialized log message
338 createDoc ".register.abs" "haskell" ""
339 message SClientRegisterCapability
341 doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
342 msg <- message SWindowLogMessage
343 liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
345 -- now unregister it by sending a specific createDoc
346 createDoc ".unregister.abs" "haskell" ""
347 message SClientUnregisterCapability
349 createDoc (curDir </> "Bar.watch") "haskell" ""
350 void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
351 count 0 $ loggingNotification
355 didChangeCaps :: ClientCapabilities
356 didChangeCaps = def { _workspace = Just workspaceCaps }
358 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
359 configCaps = DidChangeConfigurationClientCapabilities (Just True)
361 docChangesCaps :: ClientCapabilities
362 docChangesCaps = def { _workspace = Just workspaceCaps }
364 workspaceCaps = def { _workspaceEdit = Just editCaps }
365 editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing
368 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
369 findExeRecursive exe dir = do
370 me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
372 Just e -> return (Just e)
374 subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
375 foldM (\acc subdir -> case acc of
376 Just y -> pure $ Just y
377 Nothing -> findExeRecursive exe subdir)
381 -- | So we can find the dummy-server with cabal run
382 -- since it doesnt put build tools on the path (only cabal test)
384 let serverName = "dummy-server"
385 e <- findExecutable serverName
386 e' <- findExeRecursive serverName "dist-newstyle"
387 pure $ fromJust $ e <|> e'