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
28 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
29 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
32 describe "Session" $ do
34 let session = runSession "hie" fullCaps "test/data/renamePass" $ do
35 openDoc "Desktop/simple.hs" "haskell"
36 skipMany loggingNotification
38 in session `shouldThrow` anySessionException
39 it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do
40 rsp <- initializeResponse
41 liftIO $ rsp ^. result `shouldSatisfy` isLeft
43 it "runSessionWithConfig" $
44 runSession "hie" didChangeCaps "test/data/renamePass" $ return ()
46 describe "withTimeout" $ do
48 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
49 openDoc "Desktop/simple.hs" "haskell"
50 -- won't receive a request - will timeout
51 -- incoming logging requests shouldn't increase the
53 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
54 -- wait just a bit longer than 5 seconds so we have time
55 -- to open the document
56 in timeout 6000000 sesh `shouldThrow` anySessionException
58 it "doesn't time out" $
59 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
60 openDoc "Desktop/simple.hs" "haskell"
61 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
62 in void $ timeout 6000000 sesh
64 it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do
65 doc <- openDoc "Desktop/simple.hs" "haskell"
67 getDocumentSymbols doc
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 }) "hie" 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 }) "hie" 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}) "hie" 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}) "hie" fullCaps "test/data/renamePass" $ do
110 liftIO $ threadDelay $ 10 * 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 "hie" 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 "hie" 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 "hie" "test/data/renamePass"
135 let selector (ReplayOutOfOrder _ _) = True
137 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
139 describe "manual javascript session" $
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 "hie" def "test/data/refactor" $ do
155 doc <- openDoc "Main.hs" "haskell"
157 let args = toJSON $ AOP (doc ^. uri)
160 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
161 request_ WorkspaceExecuteCommand reqParams
163 editReq <- message :: Session ApplyWorkspaceEditRequest
165 let (Just cs) = editReq ^. params . edit . changes
166 [(u, List es)] = HM.toList cs
167 u `shouldBe` doc ^. uri
168 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
172 contents <- documentContents doc
173 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
175 describe "getDocumentEdit" $
176 it "automatically consumes applyedit requests" $
177 runSession "hie" fullCaps "test/data/refactor" $ do
178 doc <- openDoc "Main.hs" "haskell"
180 let args = toJSON $ AOP (doc ^. uri)
183 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
184 request_ WorkspaceExecuteCommand reqParams
185 contents <- getDocumentEdit doc
186 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
189 describe "getCodeActions" $
190 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
191 doc <- openDoc "Main.hs" "haskell"
193 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
194 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
196 describe "getAllCodeActions" $
197 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
198 doc <- openDoc "Main.hs" "haskell"
199 _ <- waitForDiagnostics
200 actions <- getAllCodeActions doc
202 let [CACodeAction action] = actions
203 action ^. title `shouldBe` "Apply hint:Redundant bracket"
204 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
206 describe "getDocumentSymbols" $
207 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
208 doc <- openDoc "Desktop/simple.hs" "haskell"
210 skipMany loggingNotification
214 Left (mainSymbol:_) <- getDocumentSymbols doc
217 mainSymbol ^. name `shouldBe` "main"
218 mainSymbol ^. kind `shouldBe` SkFunction
219 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
221 describe "applyEdit" $ do
222 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
223 doc <- openDoc "Desktop/simple.hs" "haskell"
224 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
225 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
226 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
227 liftIO $ newVersion `shouldBe` oldVersion + 1
228 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
229 doc <- openDoc "Desktop/simple.hs" "haskell"
230 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
232 contents <- documentContents doc
233 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
235 describe "getCompletions" $
236 it "works" $ runSession "hie" def "test/data/renamePass" $ do
237 doc <- openDoc "Desktop/simple.hs" "haskell"
239 -- wait for module to be loaded
240 skipMany loggingNotification
244 comps <- getCompletions doc (Position 5 5)
245 let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
247 item ^. label `shouldBe` "interactWithUser"
248 item ^. kind `shouldBe` Just CiFunction
249 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
251 describe "getReferences" $
252 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
253 doc <- openDoc "Desktop/simple.hs" "haskell"
254 let pos = Position 40 3 -- interactWithUser
256 refs <- getReferences doc pos True
257 liftIO $ refs `shouldContain` map (Location uri) [
263 describe "getDefinitions" $
264 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
265 doc <- openDoc "Desktop/simple.hs" "haskell"
266 let pos = Position 49 25 -- addItem
267 defs <- getDefinitions doc pos
268 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
270 describe "getTypeDefinitions" $
271 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
272 doc <- openDoc "Desktop/simple.hs" "haskell"
273 let pos = Position 20 23 -- Quit value
274 defs <- getTypeDefinitions doc pos
275 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
277 describe "waitForDiagnosticsSource" $
278 it "works" $ runSession "hie" fullCaps "test/data" $ do
279 openDoc "Error.hs" "haskell"
280 [diag] <- waitForDiagnosticsSource "bios"
282 diag ^. severity `shouldBe` Just DsError
283 diag ^. source `shouldBe` Just "bios"
285 describe "rename" $ do
286 it "works" $ pendingWith "HaRe not in hie-bios yet"
287 it "works on javascript" $
288 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
289 doc <- openDoc "test.js" "javascript"
290 rename doc (Position 2 11) "bar"
291 documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
293 -- runSession "hie" fullCaps "test/data" $ do
294 -- doc <- openDoc "Rename.hs" "haskell"
295 -- rename doc (Position 1 0) "bar"
296 -- documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
298 describe "getHover" $
299 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
300 doc <- openDoc "Desktop/simple.hs" "haskell"
301 -- hover returns nothing until module is loaded
302 skipManyTill loggingNotification $ count 2 noDiagnostics
303 hover <- getHover doc (Position 45 9) -- putStrLn
304 liftIO $ hover `shouldSatisfy` isJust
306 describe "getHighlights" $
307 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
308 doc <- openDoc "Desktop/simple.hs" "haskell"
309 skipManyTill loggingNotification $ count 2 noDiagnostics
310 highlights <- getHighlights doc (Position 27 4) -- addItem
311 liftIO $ length highlights `shouldBe` 4
313 describe "formatDoc" $
314 it "works" $ runSession "hie" fullCaps "test/data" $ do
315 doc <- openDoc "Format.hs" "haskell"
316 oldContents <- documentContents doc
317 formatDoc doc (FormattingOptions 4 True)
318 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
320 describe "formatRange" $
321 it "works" $ runSession "hie" fullCaps "test/data" $ do
322 doc <- openDoc "Format.hs" "haskell"
323 oldContents <- documentContents doc
324 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
325 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
327 describe "closeDoc" $
330 runSession "hie" fullCaps "test/data" $ do
331 doc <- openDoc "Format.hs" "haskell"
333 -- need to evaluate to throw
334 documentContents doc >>= liftIO . print
335 in sesh `shouldThrow` anyException
338 it "works" $ runSession "hie" fullCaps "test/data" $ do
339 openDoc "Format.hs" "haskell"
340 let pred (NotLogMessage _) = True
344 describe "ignoreLogNotifications" $
346 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do
347 openDoc "Format.hs" "haskell"
348 void publishDiagnosticsNotification
350 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
352 didChangeCaps :: ClientCapabilities
353 didChangeCaps = def { _workspace = Just workspaceCaps }
355 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
356 configCaps = DidChangeConfigurationClientCapabilities (Just True)
358 docChangesCaps :: ClientCapabilities
359 docChangesCaps = def { _workspace = Just workspaceCaps }
361 workspaceCaps = def { _workspaceEdit = Just editCaps }
362 editCaps = WorkspaceEditClientCapabilities (Just True)
364 data ApplyOneParams = AOP
366 , start_pos :: Position
367 , hintTitle :: String
368 } deriving (Generic, ToJSON)