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 in sesh `shouldThrow` (== Timeout)
97 describe "SessionException" $ do
98 it "throw on time out" $
99 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do
100 skipMany loggingNotification
101 _ <- message :: Session ApplyWorkspaceEditRequest
103 in sesh `shouldThrow` anySessionException
105 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do
107 liftIO $ threadDelay $ 10 * 1000000
108 _ <- openDoc "Desktop/simple.hs" "haskell"
111 describe "UnexpectedMessageException" $ do
112 it "throws when there's an unexpected message" $
113 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
115 in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
116 it "provides the correct types that were expected and received" $
117 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
120 doc <- openDoc "Desktop/simple.hs" "haskell"
121 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
122 skipMany anyNotification
123 message :: Session RenameResponse -- the wrong type
124 in runSession "hie" fullCaps "test/data/renamePass" sesh
125 `shouldThrow` selector
127 describe "replaySession" $
128 -- This is too fickle at the moment
129 -- it "passes a test" $
130 -- replaySession "hie" "test/data/renamePass"
132 let selector (ReplayOutOfOrder _ _) = True
134 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
136 describe "manual javascript session" $
138 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
139 doc <- openDoc "test.js" "javascript"
143 Right (fooSymbol:_) <- getDocumentSymbols doc
146 fooSymbol ^. name `shouldBe` "foo"
147 fooSymbol ^. kind `shouldBe` SkFunction
149 describe "text document VFS" $
150 it "sends back didChange notifications" $
151 runSession "hie" def "test/data/refactor" $ do
152 doc <- openDoc "Main.hs" "haskell"
154 let args = toJSON $ AOP (doc ^. uri)
157 reqParams = ExecuteCommandParams "applyrefact:applyOne" (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 1 0) (Position 1 18)) "main = return 42"]
169 contents <- documentContents doc
170 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
172 describe "getDocumentEdit" $
173 it "automatically consumes applyedit requests" $
174 runSession "hie" fullCaps "test/data/refactor" $ do
175 doc <- openDoc "Main.hs" "haskell"
177 let args = toJSON $ AOP (doc ^. uri)
180 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
181 request_ WorkspaceExecuteCommand reqParams
182 contents <- getDocumentEdit doc
183 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
186 describe "getCodeActions" $
187 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
188 doc <- openDoc "Main.hs" "haskell"
190 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
191 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
193 describe "getAllCodeActions" $
194 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
195 doc <- openDoc "Main.hs" "haskell"
196 _ <- waitForDiagnostics
197 actions <- getAllCodeActions doc
199 let [CACodeAction action] = actions
200 action ^. title `shouldBe` "Apply hint:Redundant bracket"
201 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
203 describe "getDocumentSymbols" $
204 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
205 doc <- openDoc "Desktop/simple.hs" "haskell"
207 skipMany loggingNotification
211 Left (mainSymbol:_) <- getDocumentSymbols doc
214 mainSymbol ^. name `shouldBe` "main"
215 mainSymbol ^. kind `shouldBe` SkFunction
216 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
218 describe "applyEdit" $ do
219 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
220 doc <- openDoc "Desktop/simple.hs" "haskell"
221 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
222 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
223 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
224 liftIO $ newVersion `shouldBe` oldVersion + 1
225 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
226 doc <- openDoc "Desktop/simple.hs" "haskell"
227 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
229 contents <- documentContents doc
230 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
232 describe "getCompletions" $
233 it "works" $ runSession "hie" def "test/data/renamePass" $ do
234 doc <- openDoc "Desktop/simple.hs" "haskell"
236 -- wait for module to be loaded
237 skipMany loggingNotification
241 comps <- getCompletions doc (Position 5 5)
242 let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
244 item ^. label `shouldBe` "interactWithUser"
245 item ^. kind `shouldBe` Just CiFunction
246 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
248 describe "getReferences" $
249 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
250 doc <- openDoc "Desktop/simple.hs" "haskell"
251 let pos = Position 40 3 -- interactWithUser
253 refs <- getReferences doc pos True
254 liftIO $ refs `shouldContain` map (Location uri) [
260 describe "getDefinitions" $
261 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
262 doc <- openDoc "Desktop/simple.hs" "haskell"
263 let pos = Position 49 25 -- addItem
264 defs <- getDefinitions doc pos
265 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
267 describe "getTypeDefinitions" $
268 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
269 doc <- openDoc "Desktop/simple.hs" "haskell"
270 let pos = Position 20 23 -- Quit value
271 defs <- getTypeDefinitions doc pos
272 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
274 describe "waitForDiagnosticsSource" $
275 it "works" $ runSession "hie" fullCaps "test/data" $ do
276 openDoc "Error.hs" "haskell"
277 [diag] <- waitForDiagnosticsSource "bios"
279 diag ^. severity `shouldBe` Just DsError
280 diag ^. source `shouldBe` Just "bios"
283 it "works" $ runSession "hie" fullCaps "test/data" $ do
284 doc <- openDoc "Rename.hs" "haskell"
285 rename doc (Position 1 0) "bar"
286 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
288 describe "getHover" $
289 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
290 doc <- openDoc "Desktop/simple.hs" "haskell"
291 -- hover returns nothing until module is loaded
292 skipManyTill loggingNotification $ count 2 noDiagnostics
293 hover <- getHover doc (Position 45 9) -- putStrLn
294 liftIO $ hover `shouldSatisfy` isJust
296 describe "getHighlights" $
297 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
298 doc <- openDoc "Desktop/simple.hs" "haskell"
299 skipManyTill loggingNotification $ count 2 noDiagnostics
300 highlights <- getHighlights doc (Position 27 4) -- addItem
301 liftIO $ length highlights `shouldBe` 4
303 describe "formatDoc" $
304 it "works" $ runSession "hie" fullCaps "test/data" $ do
305 doc <- openDoc "Format.hs" "haskell"
306 oldContents <- documentContents doc
307 formatDoc doc (FormattingOptions 4 True)
308 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
310 describe "formatRange" $
311 it "works" $ runSession "hie" fullCaps "test/data" $ do
312 doc <- openDoc "Format.hs" "haskell"
313 oldContents <- documentContents doc
314 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
315 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
317 describe "closeDoc" $
320 runSession "hie" fullCaps "test/data" $ do
321 doc <- openDoc "Format.hs" "haskell"
323 -- need to evaluate to throw
324 documentContents doc >>= liftIO . print
325 in sesh `shouldThrow` anyException
328 it "works" $ runSession "hie" fullCaps "test/data" $ do
329 openDoc "Format.hs" "haskell"
330 let pred (NotLogMessage _) = True
334 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
336 didChangeCaps :: ClientCapabilities
337 didChangeCaps = def { _workspace = Just workspaceCaps }
339 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
340 configCaps = DidChangeConfigurationClientCapabilities (Just True)
342 docChangesCaps :: ClientCapabilities
343 docChangesCaps = def { _workspace = Just workspaceCaps }
345 workspaceCaps = def { _workspaceEdit = Just editCaps }
346 editCaps = WorkspaceEditClientCapabilities (Just True)
348 data ApplyOneParams = AOP
350 , start_pos :: Position
351 , hintTitle :: String
352 } deriving (Generic, ToJSON)