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.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
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 describe "replaySession" $
130 -- This is too fickle at the moment
131 -- it "passes a test" $
132 -- replaySession serverExe "test/data/renamePass"
134 let selector (ReplayOutOfOrder _ _) = True
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 -- -- wait for module to be loaded
229 -- skipMany loggingNotification
233 -- comps <- getCompletions doc (Position 5 5)
234 -- let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
236 -- item ^. label `shouldBe` "interactWithUser"
237 -- item ^. kind `shouldBe` Just CiFunction
238 -- item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
240 -- describe "getReferences" $
241 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
242 -- doc <- openDoc "Desktop/simple.hs" "haskell"
243 -- let pos = Position 40 3 -- interactWithUser
244 -- uri = doc ^. LSP.uri
245 -- refs <- getReferences doc pos True
246 -- liftIO $ refs `shouldContain` map (Location uri) [
247 -- mkRange 41 0 41 16
248 -- , mkRange 75 6 75 22
249 -- , mkRange 71 6 71 22
252 -- describe "getDefinitions" $
253 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
254 -- doc <- openDoc "Desktop/simple.hs" "haskell"
255 -- let pos = Position 49 25 -- addItem
256 -- defs <- getDefinitions doc pos
257 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
259 -- describe "getTypeDefinitions" $
260 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
261 -- doc <- openDoc "Desktop/simple.hs" "haskell"
262 -- let pos = Position 20 23 -- Quit value
263 -- defs <- getTypeDefinitions doc pos
264 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
266 describe "waitForDiagnosticsSource" $
267 it "works" $ runSession serverExe fullCaps "test/data" $ do
268 openDoc "Error.hs" "haskell"
269 [diag] <- waitForDiagnosticsSource "dummy-server"
271 diag ^. severity `shouldBe` Just DsWarning
272 diag ^. source `shouldBe` Just "dummy-server"
274 -- describe "rename" $ do
275 -- it "works" $ pendingWith "HaRe not in hie-bios yet"
276 -- it "works on javascript" $
277 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
278 -- doc <- openDoc "test.js" "javascript"
279 -- rename doc (Position 2 11) "bar"
280 -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
282 describe "getHover" $
283 it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
284 doc <- openDoc "Desktop/simple.hs" "haskell"
285 hover <- getHover doc (Position 45 9)
286 liftIO $ hover `shouldSatisfy` isJust
288 -- describe "getHighlights" $
289 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
290 -- doc <- openDoc "Desktop/simple.hs" "haskell"
291 -- skipManyTill loggingNotification $ count 2 noDiagnostics
292 -- highlights <- getHighlights doc (Position 27 4) -- addItem
293 -- liftIO $ length highlights `shouldBe` 4
295 -- describe "formatDoc" $
296 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
297 -- doc <- openDoc "Format.hs" "haskell"
298 -- oldContents <- documentContents doc
299 -- formatDoc doc (FormattingOptions 4 True)
300 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
302 -- describe "formatRange" $
303 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
304 -- doc <- openDoc "Format.hs" "haskell"
305 -- oldContents <- documentContents doc
306 -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
307 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
309 describe "closeDoc" $
312 runSession serverExe fullCaps "test/data" $ do
313 doc <- openDoc "Format.hs" "haskell"
315 -- need to evaluate to throw
316 documentContents doc >>= liftIO . print
317 in sesh `shouldThrow` anyException
320 it "works" $ runSession serverExe fullCaps "test/data" $ do
321 openDoc "Format.hs" "haskell"
322 let pred (NotLogMessage _) = True
326 describe "ignoreLogNotifications" $
328 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do
329 openDoc "Format.hs" "haskell"
330 void publishDiagnosticsNotification
332 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
334 didChangeCaps :: ClientCapabilities
335 didChangeCaps = def { _workspace = Just workspaceCaps }
337 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
338 configCaps = DidChangeConfigurationClientCapabilities (Just True)
340 docChangesCaps :: ClientCapabilities
341 docChangesCaps = def { _workspace = Just workspaceCaps }
343 workspaceCaps = def { _workspaceEdit = Just editCaps }
344 editCaps = WorkspaceEditClientCapabilities (Just True)
347 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
348 findExeRecursive exe dir = do
349 me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
351 Just e -> return (Just e)
353 subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
354 foldM (\acc subdir -> case acc of
355 Just y -> pure $ Just y
356 Nothing -> findExeRecursive exe subdir)
360 -- | So we can find the dummy-server with cabal run
361 -- since it doesnt put build tools on the path (only cabal test)
363 let serverName = "dummy-server"
364 e <- findExecutable serverName
365 e' <- findExeRecursive serverName "dist-newstyle"
366 pure $ fromJust $ e <|> e'