1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
9 import qualified Data.HashMap.Strict as HM
11 import qualified Data.Text as T
12 import Control.Applicative.Combinators
13 import Control.Concurrent
14 import Control.Monad.IO.Class
16 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
27 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
28 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
31 describe "Session" $ do
33 let session = runSession "hie" fullCaps "test/data/renamePass" $ do
34 openDoc "Desktop/simple.hs" "haskell"
35 skipMany loggingNotification
37 in session `shouldThrow` anySessionException
38 it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do
39 rsp <- initializeResponse
40 liftIO $ rsp ^. result `shouldNotBe` Nothing
42 it "runSessionWithConfig" $
43 runSession "hie" didChangeCaps "test/data/renamePass" $ return ()
45 describe "withTimeout" $ do
47 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
48 openDoc "Desktop/simple.hs" "haskell"
49 -- won't receive a request - will timeout
50 -- incoming logging requests shouldn't increase the
52 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
53 -- wait just a bit longer than 5 seconds so we have time
54 -- to open the document
55 in timeout 6000000 sesh `shouldThrow` anySessionException
57 it "doesn't time out" $
58 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
59 openDoc "Desktop/simple.hs" "haskell"
60 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
61 in void $ timeout 6000000 sesh
63 it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do
64 doc <- openDoc "Desktop/simple.hs" "haskell"
66 getDocumentSymbols doc
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 }) "hie" 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 }) "hie" 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}) "hie" 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}) "hie" fullCaps "test/data/renamePass" $ do
109 liftIO $ threadDelay $ 10 * 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 "hie" 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 "hie" 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 "hie" "test/data/renamePass"
134 let selector (ReplayOutOfOrder _ _) = True
136 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
138 describe "manual javascript session" $
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 "hie" def "test/data/refactor" $ do
154 doc <- openDoc "Main.hs" "haskell"
156 let args = toJSON $ AOP (doc ^. uri)
159 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
160 request_ WorkspaceExecuteCommand reqParams
162 editReq <- message :: Session ApplyWorkspaceEditRequest
164 let (Just cs) = editReq ^. params . edit . changes
165 [(u, List es)] = HM.toList cs
166 u `shouldBe` doc ^. uri
167 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
171 contents <- documentContents doc
172 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
174 describe "getDocumentEdit" $
175 it "automatically consumes applyedit requests" $
176 runSession "hie" fullCaps "test/data/refactor" $ do
177 doc <- openDoc "Main.hs" "haskell"
179 let args = toJSON $ AOP (doc ^. uri)
182 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
183 request_ WorkspaceExecuteCommand reqParams
184 contents <- getDocumentEdit doc
185 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
188 describe "getCodeActions" $
189 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
190 doc <- openDoc "Main.hs" "haskell"
192 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
193 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
195 describe "getAllCodeActions" $
196 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
197 doc <- openDoc "Main.hs" "haskell"
198 _ <- waitForDiagnostics
199 actions <- getAllCodeActions doc
201 let [CACodeAction action] = actions
202 action ^. title `shouldBe` "Apply hint:Redundant bracket"
203 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
205 describe "getDocumentSymbols" $
206 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
207 doc <- openDoc "Desktop/simple.hs" "haskell"
209 skipMany loggingNotification
213 Left (mainSymbol:_) <- getDocumentSymbols doc
216 mainSymbol ^. name `shouldBe` "main"
217 mainSymbol ^. kind `shouldBe` SkFunction
218 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
220 describe "applyEdit" $ do
221 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
222 doc <- openDoc "Desktop/simple.hs" "haskell"
223 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
224 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
225 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
226 liftIO $ newVersion `shouldBe` oldVersion + 1
227 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
228 doc <- openDoc "Desktop/simple.hs" "haskell"
229 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
231 contents <- documentContents doc
232 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
234 describe "getCompletions" $
235 it "works" $ runSession "hie" def "test/data/renamePass" $ do
236 doc <- openDoc "Desktop/simple.hs" "haskell"
238 -- wait for module to be loaded
239 skipMany loggingNotification
243 comps <- getCompletions doc (Position 5 5)
244 let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
246 item ^. label `shouldBe` "interactWithUser"
247 item ^. kind `shouldBe` Just CiFunction
248 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
250 describe "getReferences" $
251 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
252 doc <- openDoc "Desktop/simple.hs" "haskell"
253 let pos = Position 40 3 -- interactWithUser
255 refs <- getReferences doc pos True
256 liftIO $ refs `shouldContain` map (Location uri) [
262 describe "getDefinitions" $
263 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
264 doc <- openDoc "Desktop/simple.hs" "haskell"
265 let pos = Position 49 25 -- addItem
266 defs <- getDefinitions doc pos
267 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
269 describe "getTypeDefinitions" $
270 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
271 doc <- openDoc "Desktop/simple.hs" "haskell"
272 let pos = Position 20 23 -- Quit value
273 defs <- getTypeDefinitions doc pos
274 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
276 describe "waitForDiagnosticsSource" $
277 it "works" $ runSession "hie" fullCaps "test/data" $ do
278 openDoc "Error.hs" "haskell"
279 [diag] <- waitForDiagnosticsSource "bios"
281 diag ^. severity `shouldBe` Just DsError
282 diag ^. source `shouldBe` Just "bios"
284 describe "rename" $ do
285 it "works" $ pendingWith "HaRe not in hie-bios yet"
286 it "works on javascript" $
287 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
288 doc <- openDoc "test.js" "javascript"
289 rename doc (Position 2 11) "bar"
290 documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack
292 -- runSession "hie" fullCaps "test/data" $ do
293 -- doc <- openDoc "Rename.hs" "haskell"
294 -- rename doc (Position 1 0) "bar"
295 -- documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
297 describe "getHover" $
298 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
299 doc <- openDoc "Desktop/simple.hs" "haskell"
300 -- hover returns nothing until module is loaded
301 skipManyTill loggingNotification $ count 2 noDiagnostics
302 hover <- getHover doc (Position 45 9) -- putStrLn
303 liftIO $ hover `shouldSatisfy` isJust
305 describe "getHighlights" $
306 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
307 doc <- openDoc "Desktop/simple.hs" "haskell"
308 skipManyTill loggingNotification $ count 2 noDiagnostics
309 highlights <- getHighlights doc (Position 27 4) -- addItem
310 liftIO $ length highlights `shouldBe` 4
312 describe "formatDoc" $
313 it "works" $ runSession "hie" fullCaps "test/data" $ do
314 doc <- openDoc "Format.hs" "haskell"
315 oldContents <- documentContents doc
316 formatDoc doc (FormattingOptions 4 True)
317 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
319 describe "formatRange" $
320 it "works" $ runSession "hie" fullCaps "test/data" $ do
321 doc <- openDoc "Format.hs" "haskell"
322 oldContents <- documentContents doc
323 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
324 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
326 describe "closeDoc" $
329 runSession "hie" fullCaps "test/data" $ do
330 doc <- openDoc "Format.hs" "haskell"
332 -- need to evaluate to throw
333 documentContents doc >>= liftIO . print
334 in sesh `shouldThrow` anyException
337 it "works" $ runSession "hie" fullCaps "test/data" $ do
338 openDoc "Format.hs" "haskell"
339 let pred (NotLogMessage _) = True
343 describe "ignoreLogNotifications" $
345 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do
346 openDoc "Format.hs" "haskell"
347 void publishDiagnosticsNotification
349 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
351 didChangeCaps :: ClientCapabilities
352 didChangeCaps = def { _workspace = Just workspaceCaps }
354 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
355 configCaps = DidChangeConfigurationClientCapabilities (Just True)
357 docChangesCaps :: ClientCapabilities
358 docChangesCaps = def { _workspace = Just workspaceCaps }
360 workspaceCaps = def { _workspaceEdit = Just editCaps }
361 editCaps = WorkspaceEditClientCapabilities (Just True)
363 data ApplyOneParams = AOP
365 , start_pos :: Position
366 , hintTitle :: String
367 } deriving (Generic, ToJSON)