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" "test/data/renamePass" $ do
33 openDoc "Desktop/simple.hs" "haskell"
34 skipMany loggingNotification
36 in session `shouldThrow` anyException
37 it "initializeResponse" $ runSession "hie --lsp" "test/data/renamePass" $ do
38 rsp <- initializeResponse
39 liftIO $ rsp ^. result `shouldNotBe` Nothing
41 it "runSessionWithConfig" $
42 runSessionWithConfig (def { capabilities = didChangeCaps })
43 "hie --lsp" "test/data/renamePass" $ return ()
45 describe "withTimeout" $ do
47 let sesh = runSession "hie --lsp" "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 --lsp" "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 --lsp" "test/data/renamePass" $ do
64 doc <- openDoc "Desktop/simple.hs" "haskell"
65 withTimeout 3 $ getDocumentSymbols doc
66 liftIO $ threadDelay 5000000
67 -- shouldn't throw an exception
68 getDocumentSymbols doc
71 it "overrides global message timeout" $
73 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
74 doc <- openDoc "Desktop/simple.hs" "haskell"
75 -- shouldn't time out in here since we are overriding it
76 withTimeout 10 $ liftIO $ threadDelay 7000000
77 getDocumentSymbols doc
79 in sesh `shouldReturn` True
81 it "unoverrides global message timeout" $
83 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
84 doc <- openDoc "Desktop/simple.hs" "haskell"
85 -- shouldn't time out in here since we are overriding it
86 withTimeout 10 $ liftIO $ threadDelay 7000000
87 getDocumentSymbols doc
89 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
90 in sesh `shouldThrow` (== Timeout)
93 describe "SessionException" $ do
94 it "throw on time out" $
95 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
96 skipMany loggingNotification
97 _ <- message :: Session ApplyWorkspaceEditRequest
99 in sesh `shouldThrow` anySessionException
101 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do
103 liftIO $ threadDelay 10
104 _ <- openDoc "Desktop/simple.hs" "haskell"
107 describe "UnexpectedMessageException" $ do
108 it "throws when there's an unexpected message" $
109 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
111 in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
112 it "provides the correct types that were expected and received" $
113 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
116 doc <- openDoc "Desktop/simple.hs" "haskell"
117 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
118 skipMany anyNotification
119 message :: Session RenameResponse -- the wrong type
120 in runSession "hie --lsp" "test/data/renamePass" sesh
121 `shouldThrow` selector
123 describe "replaySession" $ do
125 replaySession "hie --lsp" "test/data/renamePass"
127 let selector (ReplayOutOfOrder _ _) = True
129 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
131 describe "manual javascript session" $
133 runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
134 doc <- openDoc "test.js" "javascript"
138 (fooSymbol:_) <- getDocumentSymbols doc
141 fooSymbol ^. name `shouldBe` "foo"
142 fooSymbol ^. kind `shouldBe` SkFunction
144 describe "text document VFS" $
145 it "sends back didChange notifications" $
146 runSession "hie --lsp" "test/data/refactor" $ do
147 doc <- openDoc "Main.hs" "haskell"
149 let args = toJSON $ AOP (doc ^. uri)
152 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
153 sendRequest_ WorkspaceExecuteCommand reqParams
155 editReq <- message :: Session ApplyWorkspaceEditRequest
157 let (Just cs) = editReq ^. params . edit . changes
158 [(u, List es)] = HM.toList cs
159 u `shouldBe` doc ^. uri
160 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
164 contents <- documentContents doc
165 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
167 describe "getDocumentEdit" $
168 it "automatically consumes applyedit requests" $
169 runSession "hie --lsp" "test/data/refactor" $ do
170 doc <- openDoc "Main.hs" "haskell"
172 let args = toJSON $ AOP (doc ^. uri)
175 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
176 sendRequest_ WorkspaceExecuteCommand reqParams
177 contents <- getDocumentEdit doc
178 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
181 describe "getAllCodeActions" $
182 it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
183 doc <- openDoc "Main.hs" "haskell"
184 _ <- waitForDiagnostics
185 actions <- getAllCodeActions doc
187 let [CommandOrCodeActionCommand action] = actions
188 action ^. title `shouldBe` "Apply hint:Redundant bracket"
189 action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
191 describe "getDocumentSymbols" $
192 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
193 doc <- openDoc "Desktop/simple.hs" "haskell"
195 skipMany loggingNotification
199 (mainSymbol:_) <- getDocumentSymbols doc
202 mainSymbol ^. name `shouldBe` "main"
203 mainSymbol ^. kind `shouldBe` SkFunction
204 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
205 mainSymbol ^. containerName `shouldBe` Nothing
207 describe "applyEdit" $ do
208 it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do
209 doc <- openDoc "Desktop/simple.hs" "haskell"
210 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
211 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
212 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
213 liftIO $ newVersion `shouldBe` oldVersion + 1
214 it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do
215 doc <- openDoc "Desktop/simple.hs" "haskell"
216 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
218 contents <- documentContents doc
219 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
221 describe "getCompletions" $
222 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
223 doc <- openDoc "Desktop/simple.hs" "haskell"
224 [item] <- getCompletions doc (Position 5 5)
226 item ^. label `shouldBe` "interactWithUser"
227 item ^. kind `shouldBe` Just CiFunction
228 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
230 describe "getReferences" $
231 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
232 doc <- openDoc "Desktop/simple.hs" "haskell"
233 let pos = Position 40 3 -- interactWithUser
235 refs <- getReferences doc pos True
236 liftIO $ refs `shouldContain` map (Location uri) [
242 describe "getDefinitions" $
243 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
244 doc <- openDoc "Desktop/simple.hs" "haskell"
245 let pos = Position 49 25 -- addItem
246 defs <- getDefinitions doc pos
247 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
249 describe "waitForDiagnosticsSource" $
250 it "works" $ runSession "hie --lsp" "test/data" $ do
251 openDoc "Error.hs" "haskell"
252 [diag] <- waitForDiagnosticsSource "ghcmod"
254 diag ^. severity `shouldBe` Just DsError
255 diag ^. source `shouldBe` Just "ghcmod"
258 it "works" $ runSession "hie --lsp" "test/data" $ do
259 doc <- openDoc "Rename.hs" "haskell"
260 rename doc (Position 1 0) "bar"
261 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
263 describe "getHover" $
264 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
265 doc <- openDoc "Desktop/simple.hs" "haskell"
266 -- hover returns nothing until module is loaded
267 skipManyTill loggingNotification $ count 2 noDiagnostics
268 hover <- getHover doc (Position 45 9) -- putStrLn
269 liftIO $ hover `shouldSatisfy` isJust
271 describe "getHighlights" $
272 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
273 doc <- openDoc "Desktop/simple.hs" "haskell"
274 skipManyTill loggingNotification $ count 2 noDiagnostics
275 highlights <- getHighlights doc (Position 27 4) -- addItem
276 liftIO $ length highlights `shouldBe` 4
278 describe "formatDoc" $
279 it "works" $ runSession "hie --lsp" "test/data" $ do
280 doc <- openDoc "Format.hs" "haskell"
281 oldContents <- documentContents doc
282 formatDoc doc (FormattingOptions 4 True)
283 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
285 describe "formatRange" $
286 it "works" $ runSession "hie --lsp" "test/data" $ do
287 doc <- openDoc "Format.hs" "haskell"
288 oldContents <- documentContents doc
289 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
290 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
292 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
294 didChangeCaps :: ClientCapabilities
295 didChangeCaps = def { _workspace = Just workspaceCaps }
297 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
298 configCaps = DidChangeConfigurationClientCapabilities (Just True)
300 docChangesCaps :: ClientCapabilities
301 docChangesCaps = def { _workspace = Just workspaceCaps }
303 workspaceCaps = def { _workspaceEdit = Just editCaps }
304 editCaps = WorkspaceEditClientCapabilities (Just True)
306 data ApplyOneParams = AOP
308 , start_pos :: Position
309 , hintTitle :: String
310 } deriving (Generic, ToJSON)