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)
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]))
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]))
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 item:_ <- getCompletions doc (Position 5 5)
243 item ^. label `shouldBe` "interactWithUser"
244 item ^. kind `shouldBe` Just CiFunction
245 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
247 describe "getReferences" $
248 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
249 doc <- openDoc "Desktop/simple.hs" "haskell"
250 let pos = Position 40 3 -- interactWithUser
252 refs <- getReferences doc pos True
253 liftIO $ refs `shouldContain` map (Location uri) [
259 describe "getDefinitions" $
260 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
261 doc <- openDoc "Desktop/simple.hs" "haskell"
262 let pos = Position 49 25 -- addItem
263 defs <- getDefinitions doc pos
264 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
266 describe "getTypeDefinitions" $
267 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
268 doc <- openDoc "Desktop/simple.hs" "haskell"
269 let pos = Position 20 23 -- Quit value
270 defs <- getTypeDefinitions doc pos
271 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
273 describe "waitForDiagnosticsSource" $
274 it "works" $ runSession "hie" fullCaps "test/data" $ do
275 openDoc "Error.hs" "haskell"
276 [diag] <- waitForDiagnosticsSource "ghcmod"
278 diag ^. severity `shouldBe` Just DsError
279 diag ^. source `shouldBe` Just "ghcmod"
282 it "works" $ runSession "hie" fullCaps "test/data" $ do
283 doc <- openDoc "Rename.hs" "haskell"
284 rename doc (Position 1 0) "bar"
285 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
287 describe "getHover" $
288 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
289 doc <- openDoc "Desktop/simple.hs" "haskell"
290 -- hover returns nothing until module is loaded
291 skipManyTill loggingNotification $ count 2 noDiagnostics
292 hover <- getHover doc (Position 45 9) -- putStrLn
293 liftIO $ hover `shouldSatisfy` isJust
295 describe "getHighlights" $
296 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
297 doc <- openDoc "Desktop/simple.hs" "haskell"
298 skipManyTill loggingNotification $ count 2 noDiagnostics
299 highlights <- getHighlights doc (Position 27 4) -- addItem
300 liftIO $ length highlights `shouldBe` 4
302 describe "formatDoc" $
303 it "works" $ runSession "hie" fullCaps "test/data" $ do
304 doc <- openDoc "Format.hs" "haskell"
305 oldContents <- documentContents doc
306 formatDoc doc (FormattingOptions 4 True)
307 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
309 describe "formatRange" $
310 it "works" $ runSession "hie" fullCaps "test/data" $ do
311 doc <- openDoc "Format.hs" "haskell"
312 oldContents <- documentContents doc
313 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
314 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
316 describe "closeDoc" $
319 runSession "hie" fullCaps "test/data" $ do
320 doc <- openDoc "Format.hs" "haskell"
322 -- need to evaluate to throw
323 documentContents doc >>= liftIO . print
324 in sesh `shouldThrow` anyException
327 it "works" $ runSession "hie" fullCaps "test/data" $ do
328 openDoc "Format.hs" "haskell"
329 let pred (NotLogMessage _) = True
333 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
335 didChangeCaps :: ClientCapabilities
336 didChangeCaps = def { _workspace = Just workspaceCaps }
338 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
339 configCaps = DidChangeConfigurationClientCapabilities (Just True)
341 docChangesCaps :: ClientCapabilities
342 docChangesCaps = def { _workspace = Just workspaceCaps }
344 workspaceCaps = def { _workspaceEdit = Just editCaps }
345 editCaps = WorkspaceEditClientCapabilities (Just True)
347 data ApplyOneParams = AOP
349 , start_pos :: Position
350 , hintTitle :: String
351 } deriving (Generic, ToJSON)