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.Capabilities
22 import Language.Haskell.LSP.Types as LSP hiding (capabilities, message)
25 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
26 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
29 describe "Session" $ do
31 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
32 let session = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
33 openDoc "Desktop/simple.hs" "haskell"
34 skipMany loggingNotification
36 in session `shouldThrow` anyException
37 it "initializeResponse" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
38 rsp <- initializeResponse
39 liftIO $ rsp ^. result `shouldNotBe` Nothing
41 it "runSessionWithConfig" $
42 runSession "hie --lsp" didChangeCaps "test/data/renamePass" $ return ()
44 describe "withTimeout" $ do
46 let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
47 openDoc "Desktop/simple.hs" "haskell"
48 -- won't receive a request - will timeout
49 -- incoming logging requests shouldn't increase the
51 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
52 -- wait just a bit longer than 5 seconds so we have time
53 -- to open the document
54 in timeout 6000000 sesh `shouldThrow` anySessionException
56 it "doesn't time out" $
57 let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
58 openDoc "Desktop/simple.hs" "haskell"
59 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
60 in void $ timeout 6000000 sesh
62 it "further timeout messages are ignored" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
63 doc <- openDoc "Desktop/simple.hs" "haskell"
64 withTimeout 3 $ getDocumentSymbols doc
65 liftIO $ threadDelay 5000000
66 -- shouldn't throw an exception
67 getDocumentSymbols doc
70 it "overrides global message timeout" $
72 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do
73 doc <- openDoc "Desktop/simple.hs" "haskell"
74 -- shouldn't time out in here since we are overriding it
75 withTimeout 10 $ liftIO $ threadDelay 7000000
76 getDocumentSymbols doc
78 in sesh `shouldReturn` True
80 it "unoverrides global message timeout" $
82 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do
83 doc <- openDoc "Desktop/simple.hs" "haskell"
84 -- shouldn't time out in here since we are overriding it
85 withTimeout 10 $ liftIO $ threadDelay 7000000
86 getDocumentSymbols doc
88 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
89 in sesh `shouldThrow` (== Timeout)
92 describe "SessionException" $ do
93 it "throw on time out" $
94 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" fullCaps "test/data/renamePass" $ do
95 skipMany loggingNotification
96 _ <- message :: Session ApplyWorkspaceEditRequest
98 in sesh `shouldThrow` anySessionException
100 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" fullCaps "test/data/renamePass" $ do
102 liftIO $ threadDelay 10
103 _ <- openDoc "Desktop/simple.hs" "haskell"
106 describe "UnexpectedMessageException" $ do
107 it "throws when there's an unexpected message" $
108 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
110 in runSession "hie --lsp" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
111 it "provides the correct types that were expected and received" $
112 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
115 doc <- openDoc "Desktop/simple.hs" "haskell"
116 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
117 skipMany anyNotification
118 message :: Session RenameResponse -- the wrong type
119 in runSession "hie --lsp" fullCaps "test/data/renamePass" sesh
120 `shouldThrow` selector
122 describe "replaySession" $ do
124 replaySession "hie --lsp" "test/data/renamePass"
126 let selector (ReplayOutOfOrder _ _) = True
128 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
130 describe "manual javascript session" $
132 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
133 doc <- openDoc "test.js" "javascript"
137 (fooSymbol:_) <- getDocumentSymbols doc
140 fooSymbol ^. name `shouldBe` "foo"
141 fooSymbol ^. kind `shouldBe` SkFunction
143 describe "text document VFS" $
144 it "sends back didChange notifications" $
145 runSession "hie --lsp" def "test/data/refactor" $ do
146 doc <- openDoc "Main.hs" "haskell"
148 let args = toJSON $ AOP (doc ^. uri)
151 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
152 sendRequest_ WorkspaceExecuteCommand reqParams
154 editReq <- message :: Session ApplyWorkspaceEditRequest
156 let (Just cs) = editReq ^. params . edit . changes
157 [(u, List es)] = HM.toList cs
158 u `shouldBe` doc ^. uri
159 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
163 contents <- documentContents doc
164 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
166 describe "getDocumentEdit" $
167 it "automatically consumes applyedit requests" $
168 runSession "hie --lsp" fullCaps "test/data/refactor" $ do
169 doc <- openDoc "Main.hs" "haskell"
171 let args = toJSON $ AOP (doc ^. uri)
174 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
175 sendRequest_ WorkspaceExecuteCommand reqParams
176 contents <- getDocumentEdit doc
177 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
180 describe "getAllCodeActions" $
181 it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do
182 doc <- openDoc "Main.hs" "haskell"
183 _ <- waitForDiagnostics
184 actions <- getAllCodeActions doc
186 let [CommandOrCodeActionCodeAction action] = actions
187 action ^. title `shouldBe` "Apply hint:Redundant bracket"
188 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
190 describe "getDocumentSymbols" $
191 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
192 doc <- openDoc "Desktop/simple.hs" "haskell"
194 skipMany loggingNotification
198 (mainSymbol:_) <- getDocumentSymbols doc
201 mainSymbol ^. name `shouldBe` "main"
202 mainSymbol ^. kind `shouldBe` SkFunction
203 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
204 mainSymbol ^. containerName `shouldBe` Nothing
206 describe "applyEdit" $ do
207 it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do
208 doc <- openDoc "Desktop/simple.hs" "haskell"
209 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
210 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
211 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
212 liftIO $ newVersion `shouldBe` oldVersion + 1
213 it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
214 doc <- openDoc "Desktop/simple.hs" "haskell"
215 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
217 contents <- documentContents doc
218 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
220 describe "getCompletions" $
221 it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do
222 doc <- openDoc "Desktop/simple.hs" "haskell"
223 item:_ <- getCompletions doc (Position 5 5)
225 item ^. label `shouldBe` "interactWithUser"
226 item ^. kind `shouldBe` Just CiFunction
227 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
229 describe "getReferences" $
230 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
231 doc <- openDoc "Desktop/simple.hs" "haskell"
232 let pos = Position 40 3 -- interactWithUser
234 refs <- getReferences doc pos True
235 liftIO $ refs `shouldContain` map (Location uri) [
241 describe "getDefinitions" $
242 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
243 doc <- openDoc "Desktop/simple.hs" "haskell"
244 let pos = Position 49 25 -- addItem
245 defs <- getDefinitions doc pos
246 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
248 describe "waitForDiagnosticsSource" $
249 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
250 openDoc "Error.hs" "haskell"
251 [diag] <- waitForDiagnosticsSource "ghcmod"
253 diag ^. severity `shouldBe` Just DsError
254 diag ^. source `shouldBe` Just "ghcmod"
257 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
258 doc <- openDoc "Rename.hs" "haskell"
259 rename doc (Position 1 0) "bar"
260 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
262 describe "getHover" $
263 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
264 doc <- openDoc "Desktop/simple.hs" "haskell"
265 -- hover returns nothing until module is loaded
266 skipManyTill loggingNotification $ count 2 noDiagnostics
267 hover <- getHover doc (Position 45 9) -- putStrLn
268 liftIO $ hover `shouldSatisfy` isJust
270 describe "getHighlights" $
271 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
272 doc <- openDoc "Desktop/simple.hs" "haskell"
273 skipManyTill loggingNotification $ count 2 noDiagnostics
274 highlights <- getHighlights doc (Position 27 4) -- addItem
275 liftIO $ length highlights `shouldBe` 4
277 describe "formatDoc" $
278 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
279 doc <- openDoc "Format.hs" "haskell"
280 oldContents <- documentContents doc
281 formatDoc doc (FormattingOptions 4 True)
282 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
284 describe "formatRange" $
285 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
286 doc <- openDoc "Format.hs" "haskell"
287 oldContents <- documentContents doc
288 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
289 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
291 describe "closeDoc" $
294 runSession "hie --lsp" fullCaps "test/data" $ do
295 doc <- openDoc "Format.hs" "haskell"
297 -- need to evaluate to throw
298 documentContents doc >>= liftIO . print
299 in sesh `shouldThrow` anyException
301 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
303 didChangeCaps :: ClientCapabilities
304 didChangeCaps = def { _workspace = Just workspaceCaps }
306 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
307 configCaps = DidChangeConfigurationClientCapabilities (Just True)
309 docChangesCaps :: ClientCapabilities
310 docChangesCaps = def { _workspace = Just workspaceCaps }
312 workspaceCaps = def { _workspaceEdit = Just editCaps }
313 editCaps = WorkspaceEditClientCapabilities (Just True)
315 data ApplyOneParams = AOP
317 , start_pos :: Position
318 , hintTitle :: String
319 } deriving (Generic, ToJSON)