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 as LSP hiding (capabilities, message)
24 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
25 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
28 describe "Session" $ do
30 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
31 let session = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
32 openDoc "Desktop/simple.hs" "haskell"
33 skipMany loggingNotification
35 in session `shouldThrow` anyException
36 it "initializeResponse" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
37 rsp <- initializeResponse
38 liftIO $ rsp ^. result `shouldNotBe` Nothing
40 it "runSessionWithConfig" $
41 runSession "hie --lsp" didChangeCaps "test/data/renamePass" $ return ()
43 describe "withTimeout" $ do
45 let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
46 openDoc "Desktop/simple.hs" "haskell"
47 -- won't receive a request - will timeout
48 -- incoming logging requests shouldn't increase the
50 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
51 -- wait just a bit longer than 5 seconds so we have time
52 -- to open the document
53 in timeout 6000000 sesh `shouldThrow` anySessionException
55 it "doesn't time out" $
56 let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
57 openDoc "Desktop/simple.hs" "haskell"
58 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
59 in void $ timeout 6000000 sesh
61 it "further timeout messages are ignored" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
62 doc <- openDoc "Desktop/simple.hs" "haskell"
63 withTimeout 3 $ getDocumentSymbols doc
64 liftIO $ threadDelay 5000000
65 -- shouldn't throw an exception
66 getDocumentSymbols doc
69 it "overrides global message timeout" $
71 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do
72 doc <- openDoc "Desktop/simple.hs" "haskell"
73 -- shouldn't time out in here since we are overriding it
74 withTimeout 10 $ liftIO $ threadDelay 7000000
75 getDocumentSymbols doc
77 in sesh `shouldReturn` True
79 it "unoverrides global message timeout" $
81 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do
82 doc <- openDoc "Desktop/simple.hs" "haskell"
83 -- shouldn't time out in here since we are overriding it
84 withTimeout 10 $ liftIO $ threadDelay 7000000
85 getDocumentSymbols doc
87 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
88 in sesh `shouldThrow` (== Timeout)
91 describe "SessionException" $ do
92 it "throw on time out" $
93 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" fullCaps "test/data/renamePass" $ do
94 skipMany loggingNotification
95 _ <- message :: Session ApplyWorkspaceEditRequest
97 in sesh `shouldThrow` anySessionException
99 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" fullCaps "test/data/renamePass" $ do
101 liftIO $ threadDelay 10
102 _ <- openDoc "Desktop/simple.hs" "haskell"
105 describe "UnexpectedMessageException" $ do
106 it "throws when there's an unexpected message" $
107 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
109 in runSession "hie --lsp" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
110 it "provides the correct types that were expected and received" $
111 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
114 doc <- openDoc "Desktop/simple.hs" "haskell"
115 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
116 skipMany anyNotification
117 message :: Session RenameResponse -- the wrong type
118 in runSession "hie --lsp" fullCaps "test/data/renamePass" sesh
119 `shouldThrow` selector
121 describe "replaySession" $ do
123 replaySession "hie --lsp" "test/data/renamePass"
125 let selector (ReplayOutOfOrder _ _) = True
127 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
129 describe "manual javascript session" $
131 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
132 doc <- openDoc "test.js" "javascript"
136 Right (fooSymbol:_) <- getDocumentSymbols doc
139 fooSymbol ^. name `shouldBe` "foo"
140 fooSymbol ^. kind `shouldBe` SkFunction
142 describe "text document VFS" $
143 it "sends back didChange notifications" $
144 runSession "hie --lsp" def "test/data/refactor" $ do
145 doc <- openDoc "Main.hs" "haskell"
147 let args = toJSON $ AOP (doc ^. uri)
150 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
151 request_ WorkspaceExecuteCommand reqParams
153 editReq <- message :: Session ApplyWorkspaceEditRequest
155 let (Just cs) = editReq ^. params . edit . changes
156 [(u, List es)] = HM.toList cs
157 u `shouldBe` doc ^. uri
158 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
162 contents <- documentContents doc
163 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
165 describe "getDocumentEdit" $
166 it "automatically consumes applyedit requests" $
167 runSession "hie --lsp" fullCaps "test/data/refactor" $ do
168 doc <- openDoc "Main.hs" "haskell"
170 let args = toJSON $ AOP (doc ^. uri)
173 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
174 request_ WorkspaceExecuteCommand reqParams
175 contents <- getDocumentEdit doc
176 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
179 describe "getCodeActions" $
180 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
181 doc <- openDoc "Main.hs" "haskell"
183 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
184 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
186 describe "getAllCodeActions" $
187 it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do
188 doc <- openDoc "Main.hs" "haskell"
189 _ <- waitForDiagnostics
190 actions <- getAllCodeActions doc
192 let [CACodeAction action] = actions
193 action ^. title `shouldBe` "Apply hint:Redundant bracket"
194 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
196 describe "getDocumentSymbols" $
197 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
198 doc <- openDoc "Desktop/simple.hs" "haskell"
200 skipMany loggingNotification
204 Left (mainSymbol:_) <- getDocumentSymbols doc
207 mainSymbol ^. name `shouldBe` "main"
208 mainSymbol ^. kind `shouldBe` SkFunction
209 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 3 4)
211 describe "applyEdit" $ do
212 it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do
213 doc <- openDoc "Desktop/simple.hs" "haskell"
214 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
215 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
216 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
217 liftIO $ newVersion `shouldBe` oldVersion + 1
218 it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
219 doc <- openDoc "Desktop/simple.hs" "haskell"
220 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
222 contents <- documentContents doc
223 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
225 describe "getCompletions" $
226 it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do
227 doc <- openDoc "Desktop/simple.hs" "haskell"
228 item:_ <- getCompletions doc (Position 5 5)
230 item ^. label `shouldBe` "interactWithUser"
231 item ^. kind `shouldBe` Just CiFunction
232 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
234 describe "getReferences" $
235 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
236 doc <- openDoc "Desktop/simple.hs" "haskell"
237 let pos = Position 40 3 -- interactWithUser
239 refs <- getReferences doc pos True
240 liftIO $ refs `shouldContain` map (Location uri) [
246 describe "getDefinitions" $
247 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
248 doc <- openDoc "Desktop/simple.hs" "haskell"
249 let pos = Position 49 25 -- addItem
250 defs <- getDefinitions doc pos
251 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
253 describe "waitForDiagnosticsSource" $
254 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
255 openDoc "Error.hs" "haskell"
256 [diag] <- waitForDiagnosticsSource "ghcmod"
258 diag ^. severity `shouldBe` Just DsError
259 diag ^. source `shouldBe` Just "ghcmod"
262 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
263 doc <- openDoc "Rename.hs" "haskell"
264 rename doc (Position 1 0) "bar"
265 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
267 describe "getHover" $
268 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
269 doc <- openDoc "Desktop/simple.hs" "haskell"
270 -- hover returns nothing until module is loaded
271 skipManyTill loggingNotification $ count 2 noDiagnostics
272 hover <- getHover doc (Position 45 9) -- putStrLn
273 liftIO $ hover `shouldSatisfy` isJust
275 describe "getHighlights" $
276 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
277 doc <- openDoc "Desktop/simple.hs" "haskell"
278 skipManyTill loggingNotification $ count 2 noDiagnostics
279 highlights <- getHighlights doc (Position 27 4) -- addItem
280 liftIO $ length highlights `shouldBe` 4
282 describe "formatDoc" $
283 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
284 doc <- openDoc "Format.hs" "haskell"
285 oldContents <- documentContents doc
286 formatDoc doc (FormattingOptions 4 True)
287 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
289 describe "formatRange" $
290 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
291 doc <- openDoc "Format.hs" "haskell"
292 oldContents <- documentContents doc
293 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
294 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
296 describe "closeDoc" $
299 runSession "hie --lsp" fullCaps "test/data" $ do
300 doc <- openDoc "Format.hs" "haskell"
302 -- need to evaluate to throw
303 documentContents doc >>= liftIO . print
304 in sesh `shouldThrow` anyException
306 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
308 didChangeCaps :: ClientCapabilities
309 didChangeCaps = def { _workspace = Just workspaceCaps }
311 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
312 configCaps = DidChangeConfigurationClientCapabilities (Just True)
314 docChangesCaps :: ClientCapabilities
315 docChangesCaps = def { _workspace = Just workspaceCaps }
317 workspaceCaps = def { _workspaceEdit = Just editCaps }
318 editCaps = WorkspaceEditClientCapabilities (Just True)
320 data ApplyOneParams = AOP
322 , start_pos :: Position
323 , hintTitle :: String
324 } deriving (Generic, ToJSON)