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) #-}
30 config = defaultConfig { logStdErr = True }
33 describe "Session" $ do
35 let session = runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
36 openDoc "Desktop/simple.hs" "haskell"
37 skipMany loggingNotification
39 in session `shouldThrow` anySessionException
40 it "initializeResponse" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
41 rsp <- initializeResponse
42 liftIO $ rsp ^. result `shouldNotBe` Nothing
44 it "runSessionWithConfig" $
45 runSessionWithConfig config "hie -d --vomit" didChangeCaps "test/data/renamePass" $ return ()
47 describe "withTimeout" $ do
49 let sesh = runSessionWithConfig config "hie -d --vomit" 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 = runSessionWithConfig config "hie -d --vomit" 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" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
66 doc <- openDoc "Desktop/simple.hs" "haskell"
67 withTimeout 3 $ getDocumentSymbols doc
68 liftIO $ threadDelay 5000000
69 -- shouldn't throw an exception
70 getDocumentSymbols doc
73 it "overrides global message timeout" $
75 runSessionWithConfig (def { messageTimeout = 5 }) "hie -d --vomit" fullCaps "test/data/renamePass" $ do
76 doc <- openDoc "Desktop/simple.hs" "haskell"
77 -- shouldn't time out in here since we are overriding it
78 withTimeout 10 $ liftIO $ threadDelay 7000000
79 getDocumentSymbols doc
81 in sesh `shouldReturn` True
83 it "unoverrides global message timeout" $
85 runSessionWithConfig (def { messageTimeout = 5 }) "hie -d --vomit" fullCaps "test/data/renamePass" $ do
86 doc <- openDoc "Desktop/simple.hs" "haskell"
87 -- shouldn't time out in here since we are overriding it
88 withTimeout 10 $ liftIO $ threadDelay 7000000
89 getDocumentSymbols doc
91 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
92 in sesh `shouldThrow` (== Timeout)
95 describe "SessionException" $ do
96 it "throw on time out" $
97 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie -d --vomit" fullCaps "test/data/renamePass" $ do
98 skipMany loggingNotification
99 _ <- message :: Session ApplyWorkspaceEditRequest
101 in sesh `shouldThrow` anySessionException
103 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie -d --vomit" fullCaps "test/data/renamePass" $ do
105 liftIO $ threadDelay 10
106 _ <- openDoc "Desktop/simple.hs" "haskell"
109 describe "UnexpectedMessageException" $ do
110 it "throws when there's an unexpected message" $
111 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
113 in runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
114 it "provides the correct types that were expected and received" $
115 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
118 doc <- openDoc "Desktop/simple.hs" "haskell"
119 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
120 skipMany anyNotification
121 message :: Session RenameResponse -- the wrong type
122 in runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" sesh
123 `shouldThrow` selector
125 describe "replaySession" $
126 -- This is too fickle at the moment
127 -- it "passes a test" $
128 -- replaySession "hie -d --vomit" "test/data/renamePass"
130 let selector (ReplayOutOfOrder _ _) = True
132 in replaySession "hie -d --vomit" "test/data/renameFail" `shouldThrow` selector
134 describe "manual javascript session" $
136 runSessionWithConfig config "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
137 doc <- openDoc "test.js" "javascript"
141 Right (fooSymbol:_) <- getDocumentSymbols doc
144 fooSymbol ^. name `shouldBe` "foo"
145 fooSymbol ^. kind `shouldBe` SkFunction
147 describe "text document VFS" $
148 it "sends back didChange notifications" $
149 runSessionWithConfig config "hie -d --vomit" def "test/data/refactor" $ do
150 doc <- openDoc "Main.hs" "haskell"
152 let args = toJSON $ AOP (doc ^. uri)
155 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
156 request_ WorkspaceExecuteCommand reqParams
158 editReq <- message :: Session ApplyWorkspaceEditRequest
160 let (Just cs) = editReq ^. params . edit . changes
161 [(u, List es)] = HM.toList cs
162 u `shouldBe` doc ^. uri
163 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
167 contents <- documentContents doc
168 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
170 describe "getDocumentEdit" $
171 it "automatically consumes applyedit requests" $
172 runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/refactor" $ do
173 doc <- openDoc "Main.hs" "haskell"
175 let args = toJSON $ AOP (doc ^. uri)
178 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
179 request_ WorkspaceExecuteCommand reqParams
180 contents <- getDocumentEdit doc
181 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
184 describe "getCodeActions" $
185 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/refactor" $ do
186 doc <- openDoc "Main.hs" "haskell"
188 [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
189 liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket"
191 describe "getAllCodeActions" $
192 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/refactor" $ do
193 doc <- openDoc "Main.hs" "haskell"
194 _ <- waitForDiagnostics
195 actions <- getAllCodeActions doc
197 let [CACodeAction action] = actions
198 action ^. title `shouldBe` "Apply hint:Redundant bracket"
199 action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
201 describe "getDocumentSymbols" $
202 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
203 doc <- openDoc "Desktop/simple.hs" "haskell"
205 skipMany loggingNotification
209 Left (mainSymbol:_) <- getDocumentSymbols doc
212 mainSymbol ^. name `shouldBe` "main"
213 mainSymbol ^. kind `shouldBe` SkFunction
214 mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30)
216 describe "applyEdit" $ do
217 it "increments the version" $ runSessionWithConfig config "hie -d --vomit" docChangesCaps "test/data/renamePass" $ do
218 doc <- openDoc "Desktop/simple.hs" "haskell"
219 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
220 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
221 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
222 liftIO $ newVersion `shouldBe` oldVersion + 1
223 it "changes the document contents" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
224 doc <- openDoc "Desktop/simple.hs" "haskell"
225 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
227 contents <- documentContents doc
228 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
230 describe "getCompletions" $
231 it "works" $ runSessionWithConfig config "hie -d --vomit" def "test/data/renamePass" $ do
232 doc <- openDoc "Desktop/simple.hs" "haskell"
234 -- wait for module to be loaded
235 skipMany loggingNotification
239 item:_ <- getCompletions doc (Position 5 5)
241 item ^. label `shouldBe` "interactWithUser"
242 item ^. kind `shouldBe` Just CiFunction
243 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
245 describe "getReferences" $
246 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
247 doc <- openDoc "Desktop/simple.hs" "haskell"
248 let pos = Position 40 3 -- interactWithUser
250 refs <- getReferences doc pos True
251 liftIO $ refs `shouldContain` map (Location uri) [
257 describe "getDefinitions" $
258 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
259 doc <- openDoc "Desktop/simple.hs" "haskell"
260 let pos = Position 49 25 -- addItem
261 defs <- getDefinitions doc pos
262 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]
264 describe "getTypeDefinitions" $
265 it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do
266 doc <- openDoc "Desktop/simple.hs" "haskell"
267 let pos = Position 20 23 -- Quit value
268 defs <- getTypeDefinitions doc pos
269 liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition
271 describe "waitForDiagnosticsSource" $
272 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data" $ do
273 openDoc "Error.hs" "haskell"
274 [diag] <- waitForDiagnosticsSource "ghcmod"
276 diag ^. severity `shouldBe` Just DsError
277 diag ^. source `shouldBe` Just "ghcmod"
280 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data" $ do
281 doc <- openDoc "Rename.hs" "haskell"
282 rename doc (Position 1 0) "bar"
283 documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"
285 describe "getHover" $
286 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
287 doc <- openDoc "Desktop/simple.hs" "haskell"
288 -- hover returns nothing until module is loaded
289 skipManyTill loggingNotification $ count 2 noDiagnostics
290 hover <- getHover doc (Position 45 9) -- putStrLn
291 liftIO $ hover `shouldSatisfy` isJust
293 describe "getHighlights" $
294 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data/renamePass" $ do
295 doc <- openDoc "Desktop/simple.hs" "haskell"
296 skipManyTill loggingNotification $ count 2 noDiagnostics
297 highlights <- getHighlights doc (Position 27 4) -- addItem
298 liftIO $ length highlights `shouldBe` 4
300 describe "formatDoc" $
301 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data" $ do
302 doc <- openDoc "Format.hs" "haskell"
303 oldContents <- documentContents doc
304 formatDoc doc (FormattingOptions 4 True)
305 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
307 describe "formatRange" $
308 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data" $ do
309 doc <- openDoc "Format.hs" "haskell"
310 oldContents <- documentContents doc
311 formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
312 documentContents doc >>= liftIO . (`shouldNotBe` oldContents)
314 describe "closeDoc" $
317 runSessionWithConfig config "hie -d --vomit" fullCaps "test/data" $ do
318 doc <- openDoc "Format.hs" "haskell"
320 -- need to evaluate to throw
321 documentContents doc >>= liftIO . print
322 in sesh `shouldThrow` anyException
325 it "works" $ runSessionWithConfig config "hie -d --vomit" fullCaps "test/data" $ do
326 openDoc "Format.hs" "haskell"
327 let pred (NotLogMessage _) = True
331 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
333 didChangeCaps :: ClientCapabilities
334 didChangeCaps = def { _workspace = Just workspaceCaps }
336 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
337 configCaps = DidChangeConfigurationClientCapabilities (Just True)
339 docChangesCaps :: ClientCapabilities
340 docChangesCaps = def { _workspace = Just workspaceCaps }
342 workspaceCaps = def { _workspaceEdit = Just editCaps }
343 editCaps = WorkspaceEditClientCapabilities (Just True)
345 data ApplyOneParams = AOP
347 , start_pos :: Position
348 , hintTitle :: String
349 } deriving (Generic, ToJSON)