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
22 import Language.Haskell.LSP.Types.Lens as LSP hiding
23 (capabilities, message, rename, applyEdit)
24 import Language.Haskell.LSP.Types.Capabilities as LSP
27 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
28 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
31 describe "Session" $ do
33 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
34 let session = runSession "hie" fullCaps "test/data/renamePass" $ do
35 openDoc "Desktop/simple.hs" "haskell"
36 skipMany loggingNotification
38 in session `shouldThrow` anyException
39 it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do
40 rsp <- initializeResponse
41 liftIO $ rsp ^. result `shouldNotBe` Nothing
43 it "runSessionWithConfig" $
44 runSession "hie" didChangeCaps "test/data/renamePass" $ return ()
46 describe "withTimeout" $ do
48 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
49 openDoc "Desktop/simple.hs" "haskell"
50 -- won't receive a request - will timeout
51 -- incoming logging requests shouldn't increase the
53 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
54 -- wait just a bit longer than 5 seconds so we have time
55 -- to open the document
56 in timeout 6000000 sesh `shouldThrow` anySessionException
58 it "doesn't time out" $
59 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
60 openDoc "Desktop/simple.hs" "haskell"
61 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
62 in void $ timeout 6000000 sesh
64 it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do
65 doc <- openDoc "Desktop/simple.hs" "haskell"
66 withTimeout 3 $ getDocumentSymbols doc
67 liftIO $ threadDelay 5000000
68 -- shouldn't throw an exception
69 getDocumentSymbols doc
72 it "overrides global message timeout" $
74 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
75 doc <- openDoc "Desktop/simple.hs" "haskell"
76 -- shouldn't time out in here since we are overriding it
77 withTimeout 10 $ liftIO $ threadDelay 7000000
78 getDocumentSymbols doc
80 in sesh `shouldReturn` True
82 it "unoverrides global message timeout" $
84 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
85 doc <- openDoc "Desktop/simple.hs" "haskell"
86 -- shouldn't time out in here since we are overriding it
87 withTimeout 10 $ liftIO $ threadDelay 7000000
88 getDocumentSymbols doc
90 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
91 in sesh `shouldThrow` (== Timeout)
94 describe "SessionException" $ do
95 it "throw on time out" $
96 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do
97 skipMany loggingNotification
98 _ <- message :: Session ApplyWorkspaceEditRequest
100 in sesh `shouldThrow` anySessionException
102 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do
104 liftIO $ threadDelay 10
105 _ <- openDoc "Desktop/simple.hs" "haskell"
108 describe "UnexpectedMessageException" $ do
109 it "throws when there's an unexpected message" $
110 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
112 in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
113 it "provides the correct types that were expected and received" $
114 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
117 doc <- openDoc "Desktop/simple.hs" "haskell"
118 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
119 skipMany anyNotification
120 message :: Session RenameResponse -- the wrong type
121 in runSession "hie" fullCaps "test/data/renamePass" sesh
122 `shouldThrow` selector
124 describe "replaySession" $
125 -- This is too fickle at the moment
126 -- it "passes a test" $
127 -- replaySession "hie" "test/data/renamePass"
129 let selector (ReplayOutOfOrder _ _) = True
131 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
133 describe "manual javascript session" $
135 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
136 doc <- openDoc "test.js" "javascript"
140 Right (fooSymbol:_) <- getDocumentSymbols doc
143 fooSymbol ^. name `shouldBe` "foo"
144 fooSymbol ^. kind `shouldBe` SkFunction
146 describe "text document VFS" $
147 it "sends back didChange notifications" $
148 runSession "hie" def "test/data/refactor" $ do
149 doc <- openDoc "Main.hs" "haskell"
151 let args = toJSON $ AOP (doc ^. uri)
154 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
155 request_ WorkspaceExecuteCommand reqParams
157 editReq <- message :: Session ApplyWorkspaceEditRequest
159 let (Just cs) = editReq ^. params . edit . changes
160 [(u, List es)] = HM.toList cs
161 u `shouldBe` doc ^. uri
162 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
166 contents <- documentContents doc
167 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
169 describe "getDocumentEdit" $
170 it "automatically consumes applyedit requests" $
171 runSession "hie" fullCaps "test/data/refactor" $ do
172 doc <- openDoc "Main.hs" "haskell"
174 let args = toJSON $ AOP (doc ^. uri)
177 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
178 request_ WorkspaceExecuteCommand reqParams
179 contents <- getDocumentEdit doc
180 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
183 describe "getCodeActions" $
184 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
185 doc <- openDoc "Main.hs" "haskell"
187 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
188 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
190 describe "getAllCodeActions" $
191 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
192 doc <- openDoc "Main.hs" "haskell"
193 _ <- waitForDiagnostics
194 actions <- getAllCodeActions doc
196 let [CACodeAction action] = actions
197 action ^. title `shouldBe` "Apply hint:Redundant bracket"
198 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
200 describe "getDocumentSymbols" $
201 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
202 doc <- openDoc "Desktop/simple.hs" "haskell"
204 skipMany loggingNotification
208 Left (mainSymbol:_) <- getDocumentSymbols doc
211 mainSymbol ^. name `shouldBe` "main"
212 mainSymbol ^. kind `shouldBe` SkFunction
213 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
215 describe "applyEdit" $ do
216 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
217 doc <- openDoc "Desktop/simple.hs" "haskell"
218 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
219 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
220 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
221 liftIO $ newVersion `shouldBe` oldVersion + 1
222 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
223 doc <- openDoc "Desktop/simple.hs" "haskell"
224 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
226 contents <- documentContents doc
227 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
229 describe "getCompletions" $
230 it "works" $ runSession "hie" def "test/data/renamePass" $ do
231 doc <- openDoc "Desktop/simple.hs" "haskell"
233 -- wait for module to be loaded
234 skipMany loggingNotification
238 item:_ <- getCompletions doc (Position 5 5)
240 item ^. label `shouldBe` "interactWithUser"
241 item ^. kind `shouldBe` Just CiFunction
242 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
244 describe "getReferences" $
245 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
246 doc <- openDoc "Desktop/simple.hs" "haskell"
247 let pos = Position 40 3 -- interactWithUser
249 refs <- getReferences doc pos True
250 liftIO $ refs `shouldContain` map (Location uri) [
256 describe "getDefinitions" $
257 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
258 doc <- openDoc "Desktop/simple.hs" "haskell"
259 let pos = Position 49 25 -- addItem
260 defs <- getDefinitions doc pos
261 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
263 describe "waitForDiagnosticsSource" $
264 it "works" $ runSession "hie" fullCaps "test/data" $ do
265 openDoc "Error.hs" "haskell"
266 [diag] <- waitForDiagnosticsSource "ghcmod"
268 diag ^. severity `shouldBe` Just DsError
269 diag ^. source `shouldBe` Just "ghcmod"
272 it "works" $ runSession "hie" fullCaps "test/data" $ do
273 doc <- openDoc "Rename.hs" "haskell"
274 rename doc (Position 1 0) "bar"
275 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
277 describe "getHover" $
278 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
279 doc <- openDoc "Desktop/simple.hs" "haskell"
280 -- hover returns nothing until module is loaded
281 skipManyTill loggingNotification $ count 2 noDiagnostics
282 hover <- getHover doc (Position 45 9) -- putStrLn
283 liftIO $ hover `shouldSatisfy` isJust
285 describe "getHighlights" $
286 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
287 doc <- openDoc "Desktop/simple.hs" "haskell"
288 skipManyTill loggingNotification $ count 2 noDiagnostics
289 highlights <- getHighlights doc (Position 27 4) -- addItem
290 liftIO $ length highlights `shouldBe` 4
292 describe "formatDoc" $
293 it "works" $ runSession "hie" fullCaps "test/data" $ do
294 doc <- openDoc "Format.hs" "haskell"
295 oldContents <- documentContents doc
296 formatDoc doc (FormattingOptions 4 True)
297 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
299 describe "formatRange" $
300 it "works" $ runSession "hie" fullCaps "test/data" $ do
301 doc <- openDoc "Format.hs" "haskell"
302 oldContents <- documentContents doc
303 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
304 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
306 describe "closeDoc" $
309 runSession "hie" fullCaps "test/data" $ do
310 doc <- openDoc "Format.hs" "haskell"
312 -- need to evaluate to throw
313 documentContents doc >>= liftIO . print
314 in sesh `shouldThrow` anyException
316 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
318 didChangeCaps :: ClientCapabilities
319 didChangeCaps = def { _workspace = Just workspaceCaps }
321 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
322 configCaps = DidChangeConfigurationClientCapabilities (Just True)
324 docChangesCaps :: ClientCapabilities
325 docChangesCaps = def { _workspace = Just workspaceCaps }
327 workspaceCaps = def { _workspaceEdit = Just editCaps }
328 editCaps = WorkspaceEditClientCapabilities (Just True)
330 data ApplyOneParams = AOP
332 , start_pos :: Position
333 , hintTitle :: String
334 } deriving (Generic, ToJSON)