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"
285 it "works" $ runSession "hie" fullCaps "test/data" $ do
286 doc <- openDoc "Rename.hs" "haskell"
287 rename doc (Position 1 0) "bar"
288 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
290 describe "getHover" $
291 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
292 doc <- openDoc "Desktop/simple.hs" "haskell"
293 -- hover returns nothing until module is loaded
294 skipManyTill loggingNotification $ count 2 noDiagnostics
295 hover <- getHover doc (Position 45 9) -- putStrLn
296 liftIO $ hover `shouldSatisfy` isJust
298 describe "getHighlights" $
299 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
300 doc <- openDoc "Desktop/simple.hs" "haskell"
301 skipManyTill loggingNotification $ count 2 noDiagnostics
302 highlights <- getHighlights doc (Position 27 4) -- addItem
303 liftIO $ length highlights `shouldBe` 4
305 describe "formatDoc" $
306 it "works" $ runSession "hie" fullCaps "test/data" $ do
307 doc <- openDoc "Format.hs" "haskell"
308 oldContents <- documentContents doc
309 formatDoc doc (FormattingOptions 4 True)
310 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
312 describe "formatRange" $
313 it "works" $ runSession "hie" fullCaps "test/data" $ do
314 doc <- openDoc "Format.hs" "haskell"
315 oldContents <- documentContents doc
316 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
317 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
319 describe "closeDoc" $
322 runSession "hie" fullCaps "test/data" $ do
323 doc <- openDoc "Format.hs" "haskell"
325 -- need to evaluate to throw
326 documentContents doc >>= liftIO . print
327 in sesh `shouldThrow` anyException
330 it "works" $ runSession "hie" fullCaps "test/data" $ do
331 openDoc "Format.hs" "haskell"
332 let pred (NotLogMessage _) = True
336 describe "ignoreLogNotifications" $
338 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do
339 openDoc "Format.hs" "haskell"
340 void publishDiagnosticsNotification
342 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
344 didChangeCaps :: ClientCapabilities
345 didChangeCaps = def { _workspace = Just workspaceCaps }
347 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
348 configCaps = DidChangeConfigurationClientCapabilities (Just True)
350 docChangesCaps :: ClientCapabilities
351 docChangesCaps = def { _workspace = Just workspaceCaps }
353 workspaceCaps = def { _workspaceEdit = Just editCaps }
354 editCaps = WorkspaceEditClientCapabilities (Just True)
356 data ApplyOneParams = AOP
358 , start_pos :: Position
359 , hintTitle :: String
360 } deriving (Generic, ToJSON)