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, rename, applyEdit)
22 import Language.Haskell.LSP.Types.Capabilities as LSP
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 Right (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 request_ 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 request_ WorkspaceExecuteCommand reqParams
176 contents <- getDocumentEdit doc
177 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
180 describe "getCodeActions" $
181 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
182 doc <- openDoc "Main.hs" "haskell"
184 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
185 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
187 describe "getAllCodeActions" $
188 it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do
189 doc <- openDoc "Main.hs" "haskell"
190 _ <- waitForDiagnostics
191 actions <- getAllCodeActions doc
193 let [CACodeAction action] = actions
194 action ^. title `shouldBe` "Apply hint:Redundant bracket"
195 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
197 describe "getDocumentSymbols" $
198 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
199 doc <- openDoc "Desktop/simple.hs" "haskell"
201 skipMany loggingNotification
205 Left (mainSymbol:_) <- getDocumentSymbols doc
208 mainSymbol ^. name `shouldBe` "main"
209 mainSymbol ^. kind `shouldBe` SkFunction
210 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
212 describe "applyEdit" $ do
213 it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do
214 doc <- openDoc "Desktop/simple.hs" "haskell"
215 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
216 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
217 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
218 liftIO $ newVersion `shouldBe` oldVersion + 1
219 it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
220 doc <- openDoc "Desktop/simple.hs" "haskell"
221 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
223 contents <- documentContents doc
224 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
226 describe "getCompletions" $
227 it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do
228 doc <- openDoc "Desktop/simple.hs" "haskell"
229 item:_ <- getCompletions doc (Position 5 5)
231 item ^. label `shouldBe` "interactWithUser"
232 item ^. kind `shouldBe` Just CiFunction
233 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
235 describe "getReferences" $
236 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
237 doc <- openDoc "Desktop/simple.hs" "haskell"
238 let pos = Position 40 3 -- interactWithUser
240 refs <- getReferences doc pos True
241 liftIO $ refs `shouldContain` map (Location uri) [
247 describe "getDefinitions" $
248 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
249 doc <- openDoc "Desktop/simple.hs" "haskell"
250 let pos = Position 49 25 -- addItem
251 defs <- getDefinitions doc pos
252 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
254 describe "waitForDiagnosticsSource" $
255 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
256 openDoc "Error.hs" "haskell"
257 [diag] <- waitForDiagnosticsSource "ghcmod"
259 diag ^. severity `shouldBe` Just DsError
260 diag ^. source `shouldBe` Just "ghcmod"
263 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
264 doc <- openDoc "Rename.hs" "haskell"
265 rename doc (Position 1 0) "bar"
266 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
268 describe "getHover" $
269 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
270 doc <- openDoc "Desktop/simple.hs" "haskell"
271 -- hover returns nothing until module is loaded
272 skipManyTill loggingNotification $ count 2 noDiagnostics
273 hover <- getHover doc (Position 45 9) -- putStrLn
274 liftIO $ hover `shouldSatisfy` isJust
276 describe "getHighlights" $
277 it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do
278 doc <- openDoc "Desktop/simple.hs" "haskell"
279 skipManyTill loggingNotification $ count 2 noDiagnostics
280 highlights <- getHighlights doc (Position 27 4) -- addItem
281 liftIO $ length highlights `shouldBe` 4
283 describe "formatDoc" $
284 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
285 doc <- openDoc "Format.hs" "haskell"
286 oldContents <- documentContents doc
287 formatDoc doc (FormattingOptions 4 True)
288 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
290 describe "formatRange" $
291 it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do
292 doc <- openDoc "Format.hs" "haskell"
293 oldContents <- documentContents doc
294 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
295 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
297 describe "closeDoc" $
300 runSession "hie --lsp" fullCaps "test/data" $ do
301 doc <- openDoc "Format.hs" "haskell"
303 -- need to evaluate to throw
304 documentContents doc >>= liftIO . print
305 in sesh `shouldThrow` anyException
307 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
309 didChangeCaps :: ClientCapabilities
310 didChangeCaps = def { _workspace = Just workspaceCaps }
312 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
313 configCaps = DidChangeConfigurationClientCapabilities (Just True)
315 docChangesCaps :: ClientCapabilities
316 docChangesCaps = def { _workspace = Just workspaceCaps }
318 workspaceCaps = def { _workspaceEdit = Just editCaps }
319 editCaps = WorkspaceEditClientCapabilities (Just True)
321 data ApplyOneParams = AOP
323 , start_pos :: Position
324 , hintTitle :: String
325 } deriving (Generic, ToJSON)