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.Concurrent
12 import Control.Monad.IO.Class
14 import Control.Lens hiding (List)
16 import Language.Haskell.LSP.Messages
17 import Language.Haskell.LSP.Test
18 import Language.Haskell.LSP.Test.Replay
19 import Language.Haskell.LSP.Types.Capabilities
20 import Language.Haskell.LSP.Types hiding (message, capabilities)
24 describe "Session" $ do
26 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
27 let session = runSession "hie --lsp" "test/data/renamePass" $ do
28 openDoc "Desktop/simple.hs" "haskell"
29 skipMany loggingNotification
31 in session `shouldThrow` anyException
32 it "initializeResponse" $ runSession "hie --lsp" "test/data/renamePass" $ do
33 rsp <- initializeResponse
34 liftIO $ rsp ^. result `shouldNotBe` Nothing
36 it "runSessionWithConfig" $
37 runSessionWithConfig (def { capabilities = didChangeCaps })
38 "hie --lsp" "test/data/renamePass" $ return ()
40 describe "withTimeout" $ do
42 let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
43 openDoc "Desktop/simple.hs" "haskell"
44 -- won't receive a request - will timeout
45 -- incoming logging requests shouldn't increase the
47 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
48 -- wait just a bit longer than 5 seconds so we have time
49 -- to open the document
50 in timeout 6000000 sesh `shouldThrow` anySessionException
52 it "doesn't time out" $
53 let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
54 openDoc "Desktop/simple.hs" "haskell"
55 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
56 in void $ timeout 6000000 sesh
58 it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do
59 doc <- openDoc "Desktop/simple.hs" "haskell"
60 withTimeout 3 $ getDocumentSymbols doc
61 liftIO $ threadDelay 5000000
62 -- shouldn't throw an exception
63 getDocumentSymbols doc
66 it "overrides global message timeout" $
68 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
69 doc <- openDoc "Desktop/simple.hs" "haskell"
70 -- shouldn't time out in here since we are overriding it
71 withTimeout 10 $ liftIO $ threadDelay 7000000
72 getDocumentSymbols doc
74 in sesh `shouldReturn` True
76 it "unoverrides global message timeout" $
78 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
79 doc <- openDoc "Desktop/simple.hs" "haskell"
80 -- shouldn't time out in here since we are overriding it
81 withTimeout 10 $ liftIO $ threadDelay 7000000
82 getDocumentSymbols doc
84 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
85 in sesh `shouldThrow` (== Timeout)
88 describe "SessionException" $ do
89 it "throw on time out" $
90 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
91 skipMany loggingNotification
92 _ <- message :: Session ApplyWorkspaceEditRequest
94 in sesh `shouldThrow` anySessionException
96 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do
98 liftIO $ threadDelay 10
99 _ <- openDoc "Desktop/simple.hs" "haskell"
102 describe "UnexpectedMessageException" $ do
103 it "throws when there's an unexpected message" $
104 let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
106 in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
107 it "provides the correct types that were expected and received" $
108 let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
111 doc <- openDoc "Desktop/simple.hs" "haskell"
112 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
113 skipMany anyNotification
114 message :: Session RenameResponse -- the wrong type
115 in runSession "hie --lsp" "test/data/renamePass" sesh
116 `shouldThrow` selector
118 describe "replaySession" $ do
120 replaySession "hie --lsp" "test/data/renamePass"
122 let selector (ReplayOutOfOrder _ _) = True
124 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
126 describe "manual javascript session" $
128 runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
129 doc <- openDoc "test.js" "javascript"
133 (fooSymbol:_) <- getDocumentSymbols doc
136 fooSymbol ^. name `shouldBe` "foo"
137 fooSymbol ^. kind `shouldBe` SkFunction
139 describe "text document VFS" $
140 it "sends back didChange notifications" $
141 runSession "hie --lsp" "test/data/refactor" $ do
142 doc <- openDoc "Main.hs" "haskell"
144 let args = toJSON $ AOP (doc ^. uri)
147 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
148 sendRequest_ WorkspaceExecuteCommand reqParams
150 editReq <- message :: Session ApplyWorkspaceEditRequest
152 let (Just cs) = editReq ^. params . edit . changes
153 [(u, List es)] = HM.toList cs
154 u `shouldBe` doc ^. uri
155 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
159 contents <- documentContents doc
160 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
162 describe "getDocumentEdit" $
163 it "automatically consumes applyedit requests" $
164 runSession "hie --lsp" "test/data/refactor" $ do
165 doc <- openDoc "Main.hs" "haskell"
167 let args = toJSON $ AOP (doc ^. uri)
170 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
171 sendRequest_ WorkspaceExecuteCommand reqParams
172 contents <- getDocumentEdit doc
173 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
176 describe "getAllCodeActions" $
177 it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
178 doc <- openDoc "Main.hs" "haskell"
179 _ <- waitForDiagnostics
180 actions <- getAllCodeActions doc
182 let [CommandOrCodeActionCommand action] = actions
183 action ^. title `shouldBe` "Apply hint:Redundant bracket"
184 action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
186 describe "getDocumentSymbols" $
187 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
188 doc <- openDoc "Desktop/simple.hs" "haskell"
190 skipMany loggingNotification
194 (mainSymbol:_) <- getDocumentSymbols doc
197 mainSymbol ^. name `shouldBe` "main"
198 mainSymbol ^. kind `shouldBe` SkFunction
199 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
200 mainSymbol ^. containerName `shouldBe` Nothing
202 describe "applyEdit" $ do
203 it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do
204 doc <- openDoc "Desktop/simple.hs" "haskell"
205 VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
206 let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
207 VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
208 liftIO $ newVersion `shouldBe` oldVersion + 1
209 it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do
210 doc <- openDoc "Desktop/simple.hs" "haskell"
211 let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
213 contents <- documentContents doc
214 liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
216 describe "getCompletions" $
217 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
218 doc <- openDoc "Desktop/simple.hs" "haskell"
219 [item] <- getCompletions doc (Position 5 5)
221 item ^. label `shouldBe` "interactWithUser"
222 item ^. kind `shouldBe` Just CiFunction
223 item ^. detail `shouldBe` Just "Items -> IO ()\nMain"
226 didChangeCaps :: ClientCapabilities
227 didChangeCaps = def { _workspace = Just workspaceCaps }
229 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
230 configCaps = DidChangeConfigurationClientCapabilities (Just True)
232 docChangesCaps :: ClientCapabilities
233 docChangesCaps = def { _workspace = Just workspaceCaps }
235 workspaceCaps = def { _workspaceEdit = Just editCaps }
236 editCaps = WorkspaceEditClientCapabilities (Just True)
238 data ApplyOneParams = AOP
240 , start_pos :: Position
241 , hintTitle :: String
242 } deriving (Generic, ToJSON)