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 "getAllCodeActions" $
180 it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do
181 doc <- openDoc "Main.hs" "haskell"
182 _ <- waitForDiagnostics
183 actions <- getAllCodeActions doc
185 let [CACodeAction action] = actions
186 action ^. title `shouldBe` "Apply hint:Redundant bracket"
187 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
189 describe "getDocumentSymbols" $
190 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
191 doc <- openDoc "Desktop/simple.hs" "haskell"
193 skipMany loggingNotification
197 Left (mainSymbol:_) <- getDocumentSymbols doc
200 mainSymbol ^. name `shouldBe` "main"
201 mainSymbol ^. kind `shouldBe` SkFunction
202 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 3 4)
204 describe "applyEdit" $ do
205 it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do
206 doc <- openDoc "Desktop/simple.hs" "haskell"
207 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
208 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
209 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
210 liftIO $ newVersion `shouldBe` oldVersion + 1
211 it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
212 doc <- openDoc "Desktop/simple.hs" "haskell"
213 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
215 contents <- documentContents doc
216 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
218 describe "getCompletions" $
219 it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do
220 doc <- openDoc "Desktop/simple.hs" "haskell"
221 item:_ <- getCompletions doc (Position 5 5)
223 item ^. label `shouldBe` "interactWithUser"
224 item ^. kind `shouldBe` Just CiFunction
225 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
227 describe "getReferences" $
228 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
229 doc <- openDoc "Desktop/simple.hs" "haskell"
230 let pos = Position 40 3 -- interactWithUser
232 refs <- getReferences doc pos True
233 liftIO $ refs `shouldContain` map (Location uri) [
239 describe "getDefinitions" $
240 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
241 doc <- openDoc "Desktop/simple.hs" "haskell"
242 let pos = Position 49 25 -- addItem
243 defs <- getDefinitions doc pos
244 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
246 describe "waitForDiagnosticsSource" $
247 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
248 openDoc "Error.hs" "haskell"
249 [diag] <- waitForDiagnosticsSource "ghcmod"
251 diag ^. severity `shouldBe` Just DsError
252 diag ^. source `shouldBe` Just "ghcmod"
255 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
256 doc <- openDoc "Rename.hs" "haskell"
257 rename doc (Position 1 0) "bar"
258 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
260 describe "getHover" $
261 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
262 doc <- openDoc "Desktop/simple.hs" "haskell"
263 -- hover returns nothing until module is loaded
264 skipManyTill loggingNotification $ count 2 noDiagnostics
265 hover <- getHover doc (Position 45 9) -- putStrLn
266 liftIO $ hover `shouldSatisfy` isJust
268 describe "getHighlights" $
269 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
270 doc <- openDoc "Desktop/simple.hs" "haskell"
271 skipManyTill loggingNotification $ count 2 noDiagnostics
272 highlights <- getHighlights doc (Position 27 4) -- addItem
273 liftIO $ length highlights `shouldBe` 4
275 describe "formatDoc" $
276 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
277 doc <- openDoc "Format.hs" "haskell"
278 oldContents <- documentContents doc
279 formatDoc doc (FormattingOptions 4 True)
280 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
282 describe "formatRange" $
283 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
284 doc <- openDoc "Format.hs" "haskell"
285 oldContents <- documentContents doc
286 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
287 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
289 describe "closeDoc" $
292 runSession "hie --lsp" fullCaps "test/data" $ do
293 doc <- openDoc "Format.hs" "haskell"
295 -- need to evaluate to throw
296 documentContents doc >>= liftIO . print
297 in sesh `shouldThrow` anyException
299 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
301 didChangeCaps :: ClientCapabilities
302 didChangeCaps = def { _workspace = Just workspaceCaps }
304 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
305 configCaps = DidChangeConfigurationClientCapabilities (Just True)
307 docChangesCaps :: ClientCapabilities
308 docChangesCaps = def { _workspace = Just workspaceCaps }
310 workspaceCaps = def { _workspaceEdit = Just editCaps }
311 editCaps = WorkspaceEditClientCapabilities (Just True)
313 data ApplyOneParams = AOP
315 , start_pos :: Position
316 , hintTitle :: String
317 } deriving (Generic, ToJSON)