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 hiding (runSession)
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) #-}
30 runSession = runSessionWithConfig (defaultConfig { logStdErr = True })
33 describe "Session" $ do
35 let session = runSession "hie" fullCaps "test/data/renamePass" $ do
36 openDoc "Desktop/simple.hs" "haskell"
37 skipMany loggingNotification
39 in session `shouldThrow` anySessionException
40 it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do
41 rsp <- initializeResponse
42 liftIO $ rsp ^. result `shouldNotBe` Nothing
44 it "runSessionWithConfig" $
45 runSession "hie" didChangeCaps "test/data/renamePass" $ return ()
47 describe "withTimeout" $ do
49 let sesh = runSession "hie -d --bios-verbose" fullCaps "test/data/renamePass" $ do
50 openDoc "Desktop/simple.hs" "haskell"
51 -- won't receive a request - will timeout
52 -- incoming logging requests shouldn't increase the
54 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
55 -- wait just a bit longer than 5 seconds so we have time
56 -- to open the document
57 in timeout 6000000 sesh `shouldThrow` anySessionException
59 it "doesn't time out" $
60 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
61 openDoc "Desktop/simple.hs" "haskell"
62 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
63 in void $ timeout 6000000 sesh
65 it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do
66 doc <- openDoc "Desktop/simple.hs" "haskell"
68 getDocumentSymbols doc
70 withTimeout 3 $ getDocumentSymbols doc
71 -- longer than the original timeout
72 liftIO $ threadDelay (5 * 10^6)
73 -- shouldn't throw an exception
74 getDocumentSymbols doc
77 it "overrides global message timeout" $
79 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
80 doc <- openDoc "Desktop/simple.hs" "haskell"
81 -- shouldn't time out in here since we are overriding it
82 withTimeout 10 $ liftIO $ threadDelay 7000000
83 getDocumentSymbols doc
85 in sesh `shouldReturn` True
87 it "unoverrides global message timeout" $
89 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
90 doc <- openDoc "Desktop/simple.hs" "haskell"
91 -- shouldn't time out in here since we are overriding it
92 withTimeout 10 $ liftIO $ threadDelay 7000000
93 getDocumentSymbols doc
95 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
96 isTimeout (Timeout _) = True
98 in sesh `shouldThrow` isTimeout
101 describe "SessionException" $ do
102 it "throw on time out" $
103 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do
104 skipMany loggingNotification
105 _ <- message :: Session ApplyWorkspaceEditRequest
107 in sesh `shouldThrow` anySessionException
109 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do
111 liftIO $ threadDelay $ 10 * 1000000
112 _ <- openDoc "Desktop/simple.hs" "haskell"
115 describe "UnexpectedMessageException" $ do
116 it "throws when there's an unexpected message" $
117 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
119 in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
120 it "provides the correct types that were expected and received" $
121 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
124 doc <- openDoc "Desktop/simple.hs" "haskell"
125 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
126 skipMany anyNotification
127 message :: Session RenameResponse -- the wrong type
128 in runSession "hie" fullCaps "test/data/renamePass" sesh
129 `shouldThrow` selector
131 describe "replaySession" $
132 -- This is too fickle at the moment
133 -- it "passes a test" $
134 -- replaySession "hie" "test/data/renamePass"
136 let selector (ReplayOutOfOrder _ _) = True
138 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
140 describe "manual javascript session" $
142 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
143 doc <- openDoc "test.js" "javascript"
147 Right (fooSymbol:_) <- getDocumentSymbols doc
150 fooSymbol ^. name `shouldBe` "foo"
151 fooSymbol ^. kind `shouldBe` SkFunction
153 describe "text document VFS" $
154 it "sends back didChange notifications" $
155 runSession "hie" def "test/data/refactor" $ do
156 doc <- openDoc "Main.hs" "haskell"
158 let args = toJSON $ AOP (doc ^. uri)
161 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
162 request_ WorkspaceExecuteCommand reqParams
164 editReq <- message :: Session ApplyWorkspaceEditRequest
166 let (Just cs) = editReq ^. params . edit . changes
167 [(u, List es)] = HM.toList cs
168 u `shouldBe` doc ^. uri
169 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
173 contents <- documentContents doc
174 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
176 describe "getDocumentEdit" $
177 it "automatically consumes applyedit requests" $
178 runSession "hie" fullCaps "test/data/refactor" $ do
179 doc <- openDoc "Main.hs" "haskell"
181 let args = toJSON $ AOP (doc ^. uri)
184 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
185 request_ WorkspaceExecuteCommand reqParams
186 contents <- getDocumentEdit doc
187 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
190 describe "getCodeActions" $
191 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
192 doc <- openDoc "Main.hs" "haskell"
194 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
195 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
197 describe "getAllCodeActions" $
198 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
199 doc <- openDoc "Main.hs" "haskell"
200 _ <- waitForDiagnostics
201 actions <- getAllCodeActions doc
203 let [CACodeAction action] = actions
204 action ^. title `shouldBe` "Apply hint:Redundant bracket"
205 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
207 describe "getDocumentSymbols" $
208 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
209 doc <- openDoc "Desktop/simple.hs" "haskell"
211 skipMany loggingNotification
215 Left (mainSymbol:_) <- getDocumentSymbols doc
218 mainSymbol ^. name `shouldBe` "main"
219 mainSymbol ^. kind `shouldBe` SkFunction
220 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
222 describe "applyEdit" $ do
223 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
224 doc <- openDoc "Desktop/simple.hs" "haskell"
225 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
226 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
227 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
228 liftIO $ newVersion `shouldBe` oldVersion + 1
229 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
230 doc <- openDoc "Desktop/simple.hs" "haskell"
231 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
233 contents <- documentContents doc
234 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
236 describe "getCompletions" $
237 it "works" $ runSession "hie" def "test/data/renamePass" $ do
238 doc <- openDoc "Desktop/simple.hs" "haskell"
240 -- wait for module to be loaded
241 skipMany loggingNotification
245 comps <- getCompletions doc (Position 5 5)
246 let item = head (filter (\x -> x ^. label == "interactWithUser") comps)
248 item ^. label `shouldBe` "interactWithUser"
249 item ^. kind `shouldBe` Just CiFunction
250 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
252 describe "getReferences" $
253 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
254 doc <- openDoc "Desktop/simple.hs" "haskell"
255 let pos = Position 40 3 -- interactWithUser
257 refs <- getReferences doc pos True
258 liftIO $ refs `shouldContain` map (Location uri) [
264 describe "getDefinitions" $
265 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
266 doc <- openDoc "Desktop/simple.hs" "haskell"
267 let pos = Position 49 25 -- addItem
268 defs <- getDefinitions doc pos
269 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
271 describe "getTypeDefinitions" $
272 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
273 doc <- openDoc "Desktop/simple.hs" "haskell"
274 let pos = Position 20 23 -- Quit value
275 defs <- getTypeDefinitions doc pos
276 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
278 describe "waitForDiagnosticsSource" $
279 it "works" $ runSession "hie" fullCaps "test/data" $ do
280 openDoc "Error.hs" "haskell"
281 [diag] <- waitForDiagnosticsSource "bios"
283 diag ^. severity `shouldBe` Just DsError
284 diag ^. source `shouldBe` Just "bios"
287 it "works" $ runSession "hie" fullCaps "test/data" $ do
288 doc <- openDoc "Rename.hs" "haskell"
289 rename doc (Position 1 0) "bar"
290 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
292 describe "getHover" $
293 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
294 doc <- openDoc "Desktop/simple.hs" "haskell"
295 -- hover returns nothing until module is loaded
296 skipManyTill loggingNotification $ count 2 noDiagnostics
297 hover <- getHover doc (Position 45 9) -- putStrLn
298 liftIO $ hover `shouldSatisfy` isJust
300 describe "getHighlights" $
301 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
302 doc <- openDoc "Desktop/simple.hs" "haskell"
303 skipManyTill loggingNotification $ count 2 noDiagnostics
304 highlights <- getHighlights doc (Position 27 4) -- addItem
305 liftIO $ length highlights `shouldBe` 4
307 describe "formatDoc" $
308 it "works" $ runSession "hie" fullCaps "test/data" $ do
309 doc <- openDoc "Format.hs" "haskell"
310 oldContents <- documentContents doc
311 formatDoc doc (FormattingOptions 4 True)
312 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
314 describe "formatRange" $
315 it "works" $ runSession "hie" fullCaps "test/data" $ do
316 doc <- openDoc "Format.hs" "haskell"
317 oldContents <- documentContents doc
318 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
319 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
321 describe "closeDoc" $
324 runSession "hie" fullCaps "test/data" $ do
325 doc <- openDoc "Format.hs" "haskell"
327 -- need to evaluate to throw
328 documentContents doc >>= liftIO . print
329 in sesh `shouldThrow` anyException
332 it "works" $ runSession "hie" fullCaps "test/data" $ do
333 openDoc "Format.hs" "haskell"
334 let pred (NotLogMessage _) = True
338 describe "ignoreLogNotifications" $
340 runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do
341 openDoc "Format.hs" "haskell"
342 void publishDiagnosticsNotification
344 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
346 didChangeCaps :: ClientCapabilities
347 didChangeCaps = def { _workspace = Just workspaceCaps }
349 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
350 configCaps = DidChangeConfigurationClientCapabilities (Just True)
352 docChangesCaps :: ClientCapabilities
353 docChangesCaps = def { _workspace = Just workspaceCaps }
355 workspaceCaps = def { _workspaceEdit = Just editCaps }
356 editCaps = WorkspaceEditClientCapabilities (Just True)
358 data ApplyOneParams = AOP
360 , start_pos :: Position
361 , hintTitle :: String
362 } deriving (Generic, ToJSON)