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)
19 import Language.Haskell.LSP.Messages
20 import Language.Haskell.LSP.Test
21 import Language.Haskell.LSP.Test.Replay
22 import Language.Haskell.LSP.Types
23 import Language.Haskell.LSP.Types.Lens as LSP hiding
24 (capabilities, message, rename, applyEdit)
25 import Language.Haskell.LSP.Types.Capabilities as LSP
26 import System.Directory
27 import System.FilePath
30 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
31 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
34 main = findServer >>= \serverExe -> hspec $ do
35 describe "Session" $ do
36 it "fails a test" $ do
37 let session = runSession serverExe fullCaps "test/data/renamePass" $ do
38 openDoc "Desktop/simple.hs" "haskell"
40 in session `shouldThrow` anySessionException
41 it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do
42 rsp <- initializeResponse
43 liftIO $ rsp ^. result `shouldSatisfy` isRight
45 it "runSessionWithConfig" $
46 runSession serverExe didChangeCaps "test/data/renamePass" $ return ()
48 describe "withTimeout" $ do
50 let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
51 openDoc "Desktop/simple.hs" "haskell"
52 -- won't receive a request - will timeout
53 -- incoming logging requests shouldn't increase the
55 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
56 -- wait just a bit longer than 5 seconds so we have time
57 -- to open the document
58 in timeout 6000000 sesh `shouldThrow` anySessionException
60 it "doesn't time out" $
61 let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do
62 openDoc "Desktop/simple.hs" "haskell"
63 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
64 in void $ timeout 6000000 sesh
66 it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do
67 doc <- openDoc "Desktop/simple.hs" "haskell"
69 withTimeout 3 $ getDocumentSymbols doc
70 -- longer than the original timeout
71 liftIO $ threadDelay (5 * 10^6)
72 -- shouldn't throw an exception
73 getDocumentSymbols doc
76 it "overrides global message timeout" $
78 runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
79 doc <- openDoc "Desktop/simple.hs" "haskell"
80 -- shouldn't time out in here since we are overriding it
81 withTimeout 10 $ liftIO $ threadDelay 7000000
82 getDocumentSymbols doc
84 in sesh `shouldReturn` True
86 it "unoverrides global message timeout" $
88 runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do
89 doc <- openDoc "Desktop/simple.hs" "haskell"
90 -- shouldn't time out in here since we are overriding it
91 withTimeout 10 $ liftIO $ threadDelay 7000000
92 getDocumentSymbols doc
94 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
95 isTimeout (Timeout _) = True
97 in sesh `shouldThrow` isTimeout
100 describe "SessionException" $ do
101 it "throw on time out" $
102 let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do
103 skipMany loggingNotification
104 _ <- message :: Session ApplyWorkspaceEditRequest
106 in sesh `shouldThrow` anySessionException
108 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do
110 liftIO $ threadDelay $ 6 * 1000000
111 _ <- openDoc "Desktop/simple.hs" "haskell"
114 describe "UnexpectedMessageException" $ do
115 it "throws when there's an unexpected message" $
116 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
118 in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
119 it "provides the correct types that were expected and received" $
120 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
123 doc <- openDoc "Desktop/simple.hs" "haskell"
124 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
125 skipMany anyNotification
126 message :: Session RenameResponse -- the wrong type
127 in runSession serverExe fullCaps "test/data/renamePass" sesh
128 `shouldThrow` selector
130 describe "replaySession" $
131 -- This is too fickle at the moment
132 -- it "passes a test" $
133 -- replaySession serverExe "test/data/renamePass"
135 let selector (ReplayOutOfOrder _ _) = True
137 in replaySession serverExe "test/data/renameFail" `shouldThrow` selector
139 -- describe "manual javascript session" $
140 -- it "passes a test" $
141 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
142 -- doc <- openDoc "test.js" "javascript"
146 -- Right (fooSymbol:_) <- getDocumentSymbols doc
149 -- fooSymbol ^. name `shouldBe` "foo"
150 -- fooSymbol ^. kind `shouldBe` SkFunction
152 describe "text document VFS" $
153 it "sends back didChange notifications" $
154 runSession serverExe def "test/data/refactor" $ do
155 doc <- openDoc "Main.hs" "haskell"
157 let args = toJSON (doc ^. uri)
158 reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
159 request_ WorkspaceExecuteCommand reqParams
161 editReq <- message :: Session ApplyWorkspaceEditRequest
163 let (Just cs) = editReq ^. params . edit . changes
164 [(u, List es)] = HM.toList cs
165 u `shouldBe` doc ^. uri
166 es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
167 contents <- documentContents doc
168 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
170 describe "getDocumentEdit" $
171 it "automatically consumes applyedit requests" $
172 runSession serverExe fullCaps "test/data/refactor" $ do
173 doc <- openDoc "Main.hs" "haskell"
175 let args = toJSON (doc ^. uri)
176 reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
177 request_ WorkspaceExecuteCommand reqParams
178 contents <- getDocumentEdit doc
179 liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
181 -- describe "getCodeActions" $
182 -- it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
183 -- doc <- openDoc "Main.hs" "haskell"
184 -- waitForDiagnostics
185 -- [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
186 -- liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
188 describe "getAllCodeActions" $
189 it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
190 doc <- openDoc "Main.hs" "haskell"
191 _ <- waitForDiagnostics
192 actions <- getAllCodeActions doc
194 let [CACodeAction action] = actions
195 action ^. title `shouldBe` "Delete this"
196 action ^. command . _Just . command `shouldBe` "deleteThis"
198 -- describe "getDocumentSymbols" $
199 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
200 -- doc <- openDoc "Desktop/simple.hs" "haskell"
202 -- skipMany loggingNotification
206 -- Left (mainSymbol:_) <- getDocumentSymbols doc
209 -- mainSymbol ^. name `shouldBe` "main"
210 -- mainSymbol ^. kind `shouldBe` SkFunction
211 -- mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
213 describe "applyEdit" $ do
214 it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do
215 doc <- openDoc "Desktop/simple.hs" "haskell"
216 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
217 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
218 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
219 liftIO $ newVersion `shouldBe` oldVersion + 1
220 it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do
221 doc <- openDoc "Desktop/simple.hs" "haskell"
222 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
224 contents <- documentContents doc
225 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
227 -- describe "getCompletions" $
228 -- it "works" $ runSession serverExe def "test/data/renamePass" $ do
229 -- doc <- openDoc "Desktop/simple.hs" "haskell"
231 -- -- wait for module to be loaded
232 -- skipMany loggingNotification
236 -- comps <- getCompletions doc (Position 5 5)
237 -- let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
239 -- item ^. label `shouldBe` "interactWithUser"
240 -- item ^. kind `shouldBe` Just CiFunction
241 -- item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
243 -- describe "getReferences" $
244 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
245 -- doc <- openDoc "Desktop/simple.hs" "haskell"
246 -- let pos = Position 40 3 -- interactWithUser
247 -- uri = doc ^. LSP.uri
248 -- refs <- getReferences doc pos True
249 -- liftIO $ refs `shouldContain` map (Location uri) [
250 -- mkRange 41 0 41 16
251 -- , mkRange 75 6 75 22
252 -- , mkRange 71 6 71 22
255 -- describe "getDefinitions" $
256 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
257 -- doc <- openDoc "Desktop/simple.hs" "haskell"
258 -- let pos = Position 49 25 -- addItem
259 -- defs <- getDefinitions doc pos
260 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
262 -- describe "getTypeDefinitions" $
263 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
264 -- doc <- openDoc "Desktop/simple.hs" "haskell"
265 -- let pos = Position 20 23 -- Quit value
266 -- defs <- getTypeDefinitions doc pos
267 -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
269 -- describe "waitForDiagnosticsSource" $
270 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
271 -- openDoc "Error.hs" "haskell"
272 -- [diag] <- waitForDiagnosticsSource "bios"
274 -- diag ^. severity `shouldBe` Just DsError
275 -- diag ^. source `shouldBe` Just "bios"
277 -- describe "rename" $ do
278 -- it "works" $ pendingWith "HaRe not in hie-bios yet"
279 -- it "works on javascript" $
280 -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
281 -- doc <- openDoc "test.js" "javascript"
282 -- rename doc (Position 2 11) "bar"
283 -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
285 -- describe "getHover" $
286 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
287 -- doc <- openDoc "Desktop/simple.hs" "haskell"
288 -- hover <- getHover doc (Position 45 9)
289 -- liftIO $ hover `shouldSatisfy` isJust
291 -- describe "getHighlights" $
292 -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do
293 -- doc <- openDoc "Desktop/simple.hs" "haskell"
294 -- skipManyTill loggingNotification $ count 2 noDiagnostics
295 -- highlights <- getHighlights doc (Position 27 4) -- addItem
296 -- liftIO $ length highlights `shouldBe` 4
298 -- describe "formatDoc" $
299 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
300 -- doc <- openDoc "Format.hs" "haskell"
301 -- oldContents <- documentContents doc
302 -- formatDoc doc (FormattingOptions 4 True)
303 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
305 -- describe "formatRange" $
306 -- it "works" $ runSession serverExe fullCaps "test/data" $ do
307 -- doc <- openDoc "Format.hs" "haskell"
308 -- oldContents <- documentContents doc
309 -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
310 -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
312 describe "closeDoc" $
315 runSession serverExe fullCaps "test/data" $ do
316 doc <- openDoc "Format.hs" "haskell"
318 -- need to evaluate to throw
319 documentContents doc >>= liftIO . print
320 in sesh `shouldThrow` anyException
323 it "works" $ runSession serverExe fullCaps "test/data" $ do
324 openDoc "Format.hs" "haskell"
325 let pred (NotLogMessage _) = True
329 describe "ignoreLogNotifications" $
331 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do
332 openDoc "Format.hs" "haskell"
333 void publishDiagnosticsNotification
335 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
337 didChangeCaps :: ClientCapabilities
338 didChangeCaps = def { _workspace = Just workspaceCaps }
340 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
341 configCaps = DidChangeConfigurationClientCapabilities (Just True)
343 docChangesCaps :: ClientCapabilities
344 docChangesCaps = def { _workspace = Just workspaceCaps }
346 workspaceCaps = def { _workspaceEdit = Just editCaps }
347 editCaps = WorkspaceEditClientCapabilities (Just True)
350 findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
351 findExeRecursive exe dir = do
352 me <- listToMaybe <$> findExecutablesInDirectories [dir] exe
354 Just e -> return (Just e)
356 subdirs <- (fmap (dir </>)) <$> listDirectory dir >>= filterM doesDirectoryExist
357 foldM (\acc subdir -> case acc of
358 Just y -> pure $ Just y
359 Nothing -> findExeRecursive exe subdir)
363 -- | So we can find the dummy-server with cabal run
364 -- since it doesnt put build tools on the path (only cabal test)
366 let serverName = "dummy-server"
367 e <- findExecutable serverName
368 e' <- findExeRecursive serverName "dist-newstyle"
369 pure $ fromJust $ e <|> e'