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"
232 item:_ <- getCompletions doc (Position 5 5)
234 item ^. label `shouldBe` "interactWithUser"
235 item ^. kind `shouldBe` Just CiFunction
236 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
238 describe "getReferences" $
239 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
240 doc <- openDoc "Desktop/simple.hs" "haskell"
241 let pos = Position 40 3 -- interactWithUser
243 refs <- getReferences doc pos True
244 liftIO $ refs `shouldContain` map (Location uri) [
250 describe "getDefinitions" $
251 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
252 doc <- openDoc "Desktop/simple.hs" "haskell"
253 let pos = Position 49 25 -- addItem
254 defs <- getDefinitions doc pos
255 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
257 describe "waitForDiagnosticsSource" $
258 it "works" $ runSession "hie" fullCaps "test/data" $ do
259 openDoc "Error.hs" "haskell"
260 [diag] <- waitForDiagnosticsSource "ghcmod"
262 diag ^. severity `shouldBe` Just DsError
263 diag ^. source `shouldBe` Just "ghcmod"
266 it "works" $ runSession "hie" fullCaps "test/data" $ do
267 doc <- openDoc "Rename.hs" "haskell"
268 rename doc (Position 1 0) "bar"
269 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
271 describe "getHover" $
272 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
273 doc <- openDoc "Desktop/simple.hs" "haskell"
274 -- hover returns nothing until module is loaded
275 skipManyTill loggingNotification $ count 2 noDiagnostics
276 hover <- getHover doc (Position 45 9) -- putStrLn
277 liftIO $ hover `shouldSatisfy` isJust
279 describe "getHighlights" $
280 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
281 doc <- openDoc "Desktop/simple.hs" "haskell"
282 skipManyTill loggingNotification $ count 2 noDiagnostics
283 highlights <- getHighlights doc (Position 27 4) -- addItem
284 liftIO $ length highlights `shouldBe` 4
286 describe "formatDoc" $
287 it "works" $ runSession "hie" fullCaps "test/data" $ do
288 doc <- openDoc "Format.hs" "haskell"
289 oldContents <- documentContents doc
290 formatDoc doc (FormattingOptions 4 True)
291 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
293 describe "formatRange" $
294 it "works" $ runSession "hie" fullCaps "test/data" $ do
295 doc <- openDoc "Format.hs" "haskell"
296 oldContents <- documentContents doc
297 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
298 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
300 describe "closeDoc" $
303 runSession "hie" fullCaps "test/data" $ do
304 doc <- openDoc "Format.hs" "haskell"
306 -- need to evaluate to throw
307 documentContents doc >>= liftIO . print
308 in sesh `shouldThrow` anyException
310 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
312 didChangeCaps :: ClientCapabilities
313 didChangeCaps = def { _workspace = Just workspaceCaps }
315 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
316 configCaps = DidChangeConfigurationClientCapabilities (Just True)
318 docChangesCaps :: ClientCapabilities
319 docChangesCaps = def { _workspace = Just workspaceCaps }
321 workspaceCaps = def { _workspaceEdit = Just editCaps }
322 editCaps = WorkspaceEditClientCapabilities (Just True)
324 data ApplyOneParams = AOP
326 , start_pos :: Position
327 , hintTitle :: String
328 } deriving (Generic, ToJSON)