1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
9 import qualified Data.HashMap.Strict as HM
10 import qualified Data.Text as T
11 import Control.Applicative.Combinators
12 import Control.Concurrent
13 import Control.Monad.IO.Class
15 import Control.Lens hiding (List)
17 import Language.Haskell.LSP.Messages
18 import Language.Haskell.LSP.Test
19 import Language.Haskell.LSP.Test.Replay
20 import Language.Haskell.LSP.Types.Capabilities
21 import Language.Haskell.LSP.Types hiding (capabilities, message)
24 {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
25 {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
28 describe "Session" $ do
30 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
31 let session = runSession "hie --lsp" "test/data/renamePass" $ do
32 openDoc "Desktop/simple.hs" "haskell"
33 skipMany loggingNotification
35 in session `shouldThrow` anyException
36 it "initializeResponse" $ runSession "hie --lsp" "test/data/renamePass" $ do
37 rsp <- initializeResponse
38 liftIO $ rsp ^. result `shouldNotBe` Nothing
40 it "runSessionWithConfig" $
41 runSessionWithConfig (def { capabilities = didChangeCaps })
42 "hie --lsp" "test/data/renamePass" $ return ()
44 describe "withTimeout" $ do
46 let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
47 openDoc "Desktop/simple.hs" "haskell"
48 -- won't receive a request - will timeout
49 -- incoming logging requests shouldn't increase the
51 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
52 -- wait just a bit longer than 5 seconds so we have time
53 -- to open the document
54 in timeout 6000000 sesh `shouldThrow` anySessionException
56 it "doesn't time out" $
57 let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
58 openDoc "Desktop/simple.hs" "haskell"
59 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
60 in void $ timeout 6000000 sesh
62 it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do
63 doc <- openDoc "Desktop/simple.hs" "haskell"
64 withTimeout 3 $ getDocumentSymbols doc
65 liftIO $ threadDelay 5000000
66 -- shouldn't throw an exception
67 getDocumentSymbols doc
70 it "overrides global message timeout" $
72 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
73 doc <- openDoc "Desktop/simple.hs" "haskell"
74 -- shouldn't time out in here since we are overriding it
75 withTimeout 10 $ liftIO $ threadDelay 7000000
76 getDocumentSymbols doc
78 in sesh `shouldReturn` True
80 it "unoverrides global message timeout" $
82 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
83 doc <- openDoc "Desktop/simple.hs" "haskell"
84 -- shouldn't time out in here since we are overriding it
85 withTimeout 10 $ liftIO $ threadDelay 7000000
86 getDocumentSymbols doc
88 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
89 in sesh `shouldThrow` (== Timeout)
92 describe "SessionException" $ do
93 it "throw on time out" $
94 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
95 skipMany loggingNotification
96 _ <- message :: Session ApplyWorkspaceEditRequest
98 in sesh `shouldThrow` anySessionException
100 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do
102 liftIO $ threadDelay 10
103 _ <- openDoc "Desktop/simple.hs" "haskell"
106 describe "UnexpectedMessageException" $ do
107 it "throws when there's an unexpected message" $
108 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
110 in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
111 it "provides the correct types that were expected and received" $
112 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
115 doc <- openDoc "Desktop/simple.hs" "haskell"
116 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
117 skipMany anyNotification
118 message :: Session RenameResponse -- the wrong type
119 in runSession "hie --lsp" "test/data/renamePass" sesh
120 `shouldThrow` selector
122 describe "replaySession" $ do
124 replaySession "hie --lsp" "test/data/renamePass"
126 let selector (ReplayOutOfOrder _ _) = True
128 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
130 describe "manual javascript session" $
132 runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
133 doc <- openDoc "test.js" "javascript"
137 (fooSymbol:_) <- getDocumentSymbols doc
140 fooSymbol ^. name `shouldBe` "foo"
141 fooSymbol ^. kind `shouldBe` SkFunction
143 describe "text document VFS" $
144 it "sends back didChange notifications" $
145 runSession "hie --lsp" "test/data/refactor" $ do
146 doc <- openDoc "Main.hs" "haskell"
148 let args = toJSON $ AOP (doc ^. uri)
151 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
152 sendRequest_ WorkspaceExecuteCommand reqParams
154 editReq <- message :: Session ApplyWorkspaceEditRequest
156 let (Just cs) = editReq ^. params . edit . changes
157 [(u, List es)] = HM.toList cs
158 u `shouldBe` doc ^. uri
159 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
163 contents <- documentContents doc
164 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
166 describe "getDocumentEdit" $
167 it "automatically consumes applyedit requests" $
168 runSession "hie --lsp" "test/data/refactor" $ do
169 doc <- openDoc "Main.hs" "haskell"
171 let args = toJSON $ AOP (doc ^. uri)
174 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
175 sendRequest_ WorkspaceExecuteCommand reqParams
176 contents <- getDocumentEdit doc
177 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"
180 describe "getAllCodeActions" $
181 it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
182 doc <- openDoc "Main.hs" "haskell"
183 _ <- waitForDiagnostics
184 actions <- getAllCodeActions doc
186 let [CommandOrCodeActionCommand action] = actions
187 action ^. title `shouldBe` "Apply hint:Redundant bracket"
188 action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
190 describe "getDocumentSymbols" $
191 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
192 doc <- openDoc "Desktop/simple.hs" "haskell"
194 skipMany loggingNotification
198 (mainSymbol:_) <- getDocumentSymbols doc
201 mainSymbol ^. name `shouldBe` "main"
202 mainSymbol ^. kind `shouldBe` SkFunction
203 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
204 mainSymbol ^. containerName `shouldBe` Nothing
206 describe "applyEdit" $ do
207 it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do
208 doc <- openDoc "Desktop/simple.hs" "haskell"
209 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
210 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
211 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
212 liftIO $ newVersion `shouldBe` oldVersion + 1
213 it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do
214 doc <- openDoc "Desktop/simple.hs" "haskell"
215 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
217 contents <- documentContents doc
218 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
220 describe "getCompletions" $
221 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
222 doc <- openDoc "Desktop/simple.hs" "haskell"
223 [item] <- getCompletions doc (Position 5 5)
225 item ^. label `shouldBe` "interactWithUser"
226 item ^. kind `shouldBe` Just CiFunction
227 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
230 didChangeCaps :: ClientCapabilities
231 didChangeCaps = def { _workspace = Just workspaceCaps }
233 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
234 configCaps = DidChangeConfigurationClientCapabilities (Just True)
236 docChangesCaps :: ClientCapabilities
237 docChangesCaps = def { _workspace = Just workspaceCaps }
239 workspaceCaps = def { _workspaceEdit = Just editCaps }
240 editCaps = WorkspaceEditClientCapabilities (Just True)
242 data ApplyOneParams = AOP
244 , start_pos :: Position
245 , hintTitle :: String
246 } deriving (Generic, ToJSON)