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 hiding (runSession)
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) #-}
30 runSession = runSessionWithConfig (defaultConfig { logStdErr = True, logMessages = True })
33 describe "Session" $ do
35 let session = runSession "hie" fullCaps "test/data/renamePass" $ do
36 openDoc "Desktop/simple.hs" "haskell"
37 skipMany loggingNotification
39 in session `shouldThrow` anySessionException
40 it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do
41 rsp <- initializeResponse
42 liftIO $ rsp ^. result `shouldNotBe` Nothing
44 it "runSessionWithConfig" $
45 runSession "hie" didChangeCaps "test/data/renamePass" $ return ()
47 describe "withTimeout" $ do
49 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
50 openDoc "Desktop/simple.hs" "haskell"
51 -- won't receive a request - will timeout
52 -- incoming logging requests shouldn't increase the
54 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
55 -- wait just a bit longer than 5 seconds so we have time
56 -- to open the document
57 in timeout 6000000 sesh `shouldThrow` anySessionException
59 it "doesn't time out" $
60 let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do
61 openDoc "Desktop/simple.hs" "haskell"
62 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
63 in void $ timeout 6000000 sesh
65 it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do
66 doc <- openDoc "Desktop/simple.hs" "haskell"
68 getDocumentSymbols doc
70 withTimeout 3 $ getDocumentSymbols doc
71 -- longer than the original timeout
72 liftIO $ threadDelay (5 * 10^6)
73 -- shouldn't throw an exception
74 getDocumentSymbols doc
77 it "overrides global message timeout" $
79 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
80 doc <- openDoc "Desktop/simple.hs" "haskell"
81 -- shouldn't time out in here since we are overriding it
82 withTimeout 10 $ liftIO $ threadDelay 7000000
83 getDocumentSymbols doc
85 in sesh `shouldReturn` True
87 it "unoverrides global message timeout" $
89 runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do
90 doc <- openDoc "Desktop/simple.hs" "haskell"
91 -- shouldn't time out in here since we are overriding it
92 withTimeout 10 $ liftIO $ threadDelay 7000000
93 getDocumentSymbols doc
95 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
96 in sesh `shouldThrow` (== Timeout)
99 describe "SessionException" $ do
100 it "throw on time out" $
101 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do
102 skipMany loggingNotification
103 _ <- message :: Session ApplyWorkspaceEditRequest
105 in sesh `shouldThrow` anySessionException
107 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do
109 liftIO $ threadDelay $ 10 * 1000000
110 _ <- openDoc "Desktop/simple.hs" "haskell"
113 describe "UnexpectedMessageException" $ do
114 it "throws when there's an unexpected message" $
115 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
117 in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
118 it "provides the correct types that were expected and received" $
119 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
122 doc <- openDoc "Desktop/simple.hs" "haskell"
123 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
124 skipMany anyNotification
125 message :: Session RenameResponse -- the wrong type
126 in runSession "hie" fullCaps "test/data/renamePass" sesh
127 `shouldThrow` selector
129 describe "replaySession" $
130 -- This is too fickle at the moment
131 -- it "passes a test" $
132 -- replaySession "hie" "test/data/renamePass"
134 let selector (ReplayOutOfOrder _ _) = True
136 in replaySession "hie" "test/data/renameFail" `shouldThrow` selector
138 describe "manual javascript session" $
140 runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
141 doc <- openDoc "test.js" "javascript"
145 Right (fooSymbol:_) <- getDocumentSymbols doc
148 fooSymbol ^. name `shouldBe` "foo"
149 fooSymbol ^. kind `shouldBe` SkFunction
151 describe "text document VFS" $
152 it "sends back didChange notifications" $
153 runSession "hie" def "test/data/refactor" $ do
154 doc <- openDoc "Main.hs" "haskell"
156 let args = toJSON $ AOP (doc ^. uri)
159 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
160 request_ WorkspaceExecuteCommand reqParams
162 editReq <- message :: Session ApplyWorkspaceEditRequest
164 let (Just cs) = editReq ^. params . edit . changes
165 [(u, List es)] = HM.toList cs
166 u `shouldBe` doc ^. uri
167 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
171 contents <- documentContents doc
172 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
174 describe "getDocumentEdit" $
175 it "automatically consumes applyedit requests" $
176 runSession "hie" fullCaps "test/data/refactor" $ do
177 doc <- openDoc "Main.hs" "haskell"
179 let args = toJSON $ AOP (doc ^. uri)
182 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
183 request_ WorkspaceExecuteCommand reqParams
184 contents <- getDocumentEdit doc
185 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
188 describe "getCodeActions" $
189 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
190 doc <- openDoc "Main.hs" "haskell"
192 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
193 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
195 describe "getAllCodeActions" $
196 it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do
197 doc <- openDoc "Main.hs" "haskell"
198 _ <- waitForDiagnostics
199 actions <- getAllCodeActions doc
201 let [CACodeAction action] = actions
202 action ^. title `shouldBe` "Apply hint:Redundant bracket"
203 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
205 describe "getDocumentSymbols" $
206 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
207 doc <- openDoc "Desktop/simple.hs" "haskell"
209 skipMany loggingNotification
213 Left (mainSymbol:_) <- getDocumentSymbols doc
216 mainSymbol ^. name `shouldBe` "main"
217 mainSymbol ^. kind `shouldBe` SkFunction
218 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
220 describe "applyEdit" $ do
221 it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do
222 doc <- openDoc "Desktop/simple.hs" "haskell"
223 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
224 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
225 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
226 liftIO $ newVersion `shouldBe` oldVersion + 1
227 it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do
228 doc <- openDoc "Desktop/simple.hs" "haskell"
229 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
231 contents <- documentContents doc
232 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
234 describe "getCompletions" $
235 it "works" $ runSession "hie" def "test/data/renamePass" $ do
236 doc <- openDoc "Desktop/simple.hs" "haskell"
238 -- wait for module to be loaded
239 skipMany loggingNotification
243 item:_ <- getCompletions doc (Position 5 5)
245 item ^. label `shouldBe` "interactWithUser"
246 item ^. kind `shouldBe` Just CiFunction
247 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
249 describe "getReferences" $
250 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
251 doc <- openDoc "Desktop/simple.hs" "haskell"
252 let pos = Position 40 3 -- interactWithUser
254 refs <- getReferences doc pos True
255 liftIO $ refs `shouldContain` map (Location uri) [
261 describe "getDefinitions" $
262 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
263 doc <- openDoc "Desktop/simple.hs" "haskell"
264 let pos = Position 49 25 -- addItem
265 defs <- getDefinitions doc pos
266 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
268 describe "getTypeDefinitions" $
269 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
270 doc <- openDoc "Desktop/simple.hs" "haskell"
271 let pos = Position 20 23 -- Quit value
272 defs <- getTypeDefinitions doc pos
273 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
275 describe "waitForDiagnosticsSource" $
276 it "works" $ runSession "hie" fullCaps "test/data" $ do
277 openDoc "Error.hs" "haskell"
278 [diag] <- waitForDiagnosticsSource "ghcmod"
280 diag ^. severity `shouldBe` Just DsError
281 diag ^. source `shouldBe` Just "ghcmod"
284 it "works" $ runSession "hie" fullCaps "test/data" $ do
285 doc <- openDoc "Rename.hs" "haskell"
286 rename doc (Position 1 0) "bar"
287 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
289 describe "getHover" $
290 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
291 doc <- openDoc "Desktop/simple.hs" "haskell"
292 -- hover returns nothing until module is loaded
293 skipManyTill loggingNotification $ count 2 noDiagnostics
294 hover <- getHover doc (Position 45 9) -- putStrLn
295 liftIO $ hover `shouldSatisfy` isJust
297 describe "getHighlights" $
298 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
299 doc <- openDoc "Desktop/simple.hs" "haskell"
300 skipManyTill loggingNotification $ count 2 noDiagnostics
301 highlights <- getHighlights doc (Position 27 4) -- addItem
302 liftIO $ length highlights `shouldBe` 4
304 describe "formatDoc" $
305 it "works" $ runSession "hie" fullCaps "test/data" $ do
306 doc <- openDoc "Format.hs" "haskell"
307 oldContents <- documentContents doc
308 formatDoc doc (FormattingOptions 4 True)
309 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
311 describe "formatRange" $
312 it "works" $ runSession "hie" fullCaps "test/data" $ do
313 doc <- openDoc "Format.hs" "haskell"
314 oldContents <- documentContents doc
315 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
316 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
318 describe "closeDoc" $
321 runSession "hie" fullCaps "test/data" $ do
322 doc <- openDoc "Format.hs" "haskell"
324 -- need to evaluate to throw
325 documentContents doc >>= liftIO . print
326 in sesh `shouldThrow` anyException
329 it "works" $ runSession "hie" fullCaps "test/data" $ do
330 openDoc "Format.hs" "haskell"
331 let pred (NotLogMessage _) = True
335 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
337 didChangeCaps :: ClientCapabilities
338 didChangeCaps = def { _workspace = Just workspaceCaps }
340 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
341 configCaps = DidChangeConfigurationClientCapabilities (Just True)
343 docChangesCaps :: ClientCapabilities
344 docChangesCaps = def { _workspace = Just workspaceCaps }
346 workspaceCaps = def { _workspaceEdit = Just editCaps }
347 editCaps = WorkspaceEditClientCapabilities (Just True)
349 data ApplyOneParams = AOP
351 , start_pos :: Position
352 , hintTitle :: String
353 } deriving (Generic, ToJSON)