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.TH.ClientCapabilities
20 import Language.Haskell.LSP.Types hiding (message, capabilities)
24 describe "manual 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 "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
33 rsp <- initializeResponse
34 liftIO $ rsp ^. result `shouldNotBe` Nothing
36 it "can register specific capabilities" $ do
37 let caps = def { _workspace = Just workspaceCaps }
38 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
39 configCaps = DidChangeConfigurationClientCapabilities (Just True)
40 conf = def { capabilities = caps }
41 runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
43 describe "withTimeout" $ do
45 let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
46 openDoc "Desktop/simple.hs" "haskell"
47 -- won't receive a request - will timeout
48 -- incoming logging requests shouldn't increase the
50 withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
51 -- wait just a bit longer than 5 seconds so we have time
52 -- to open the document
53 in timeout 6000000 sesh `shouldThrow` anySessionException
55 it "doesn't time out" $
56 let sesh = runSession "hie --lsp" "test/data/renamePass" $ do
57 openDoc "Desktop/simple.hs" "haskell"
58 withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
59 in void $ timeout 6000000 sesh
61 it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do
62 doc <- openDoc "Desktop/simple.hs" "haskell"
63 withTimeout 3 $ getDocumentSymbols doc
64 liftIO $ threadDelay 5000000
65 -- shouldn't throw an exception
66 getDocumentSymbols doc
69 it "overrides global message timeout" $
71 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
72 doc <- openDoc "Desktop/simple.hs" "haskell"
73 -- shouldn't time out in here since we are overriding it
74 withTimeout 10 $ liftIO $ threadDelay 7000000
75 getDocumentSymbols doc
77 in sesh `shouldReturn` True
79 it "unoverrides global message timeout" $
81 runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do
82 doc <- openDoc "Desktop/simple.hs" "haskell"
83 -- shouldn't time out in here since we are overriding it
84 withTimeout 10 $ liftIO $ threadDelay 7000000
85 getDocumentSymbols doc
87 skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
88 in sesh `shouldThrow` (== TimeoutException)
91 describe "exceptions" $ do
92 it "throw on time out" $
93 let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
94 skipMany loggingNotification
95 _ <- message :: Session ApplyWorkspaceEditRequest
97 in sesh `shouldThrow` anySessionException
99 it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do
101 liftIO $ threadDelay 10
102 _ <- openDoc "Desktop/simple.hs" "haskell"
105 describe "UnexpectedMessageException" $ do
106 it "throws when there's an unexpected message" $
107 let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
109 in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
110 it "provides the correct types that were expected and received" $
111 let selector (UnexpectedMessageException "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
114 doc <- openDoc "Desktop/simple.hs" "haskell"
115 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
116 skipMany anyNotification
117 message :: Session RenameResponse -- the wrong type
118 in runSession "hie --lsp" "test/data/renamePass" sesh
119 `shouldThrow` selector
121 describe "replay session" $ do
123 replaySession "hie --lsp" "test/data/renamePass"
125 let selector (ReplayOutOfOrderException _ _) = True
127 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
129 describe "manual javascript session" $
131 runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
132 doc <- openDoc "test.js" "javascript"
136 (fooSymbol:_) <- getDocumentSymbols doc
139 fooSymbol ^. name `shouldBe` "foo"
140 fooSymbol ^. kind `shouldBe` SkFunction
142 describe "text document VFS" $
143 it "sends back didChange notifications" $
144 runSession "hie --lsp" "test/data/refactor" $ do
145 doc <- openDoc "Main.hs" "haskell"
147 let args = toJSON $ AOP (doc ^. uri)
150 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
151 sendRequest_ WorkspaceExecuteCommand reqParams
153 editReq <- message :: Session ApplyWorkspaceEditRequest
155 let (Just cs) = editReq ^. params . edit . changes
156 [(u, List es)] = HM.toList cs
157 u `shouldBe` doc ^. uri
158 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
162 contents <- documentContents doc
163 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
165 describe "documentEdit" $
166 it "automatically consumes applyedit requests" $
167 runSession "hie --lsp" "test/data/refactor" $ do
168 doc <- openDoc "Main.hs" "haskell"
170 let args = toJSON $ AOP (doc ^. uri)
173 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
174 sendRequest_ WorkspaceExecuteCommand reqParams
175 contents <- getDocumentEdit doc
176 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
179 describe "getAllCodeActions" $
180 it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
181 doc <- openDoc "Main.hs" "haskell"
182 _ <- waitForDiagnostics
183 actions <- getAllCodeActions doc
185 let [CommandOrCodeActionCommand action] = actions
186 action ^. title `shouldBe` "Apply hint:Redundant bracket"
187 action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
189 describe "getDocumentSymbols" $
190 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
191 doc <- openDoc "Desktop/simple.hs" "haskell"
193 skipMany loggingNotification
197 (mainSymbol:_) <- getDocumentSymbols doc
200 mainSymbol ^. name `shouldBe` "main"
201 mainSymbol ^. kind `shouldBe` SkFunction
202 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
203 mainSymbol ^. containerName `shouldBe` Nothing
205 data ApplyOneParams = AOP
207 , start_pos :: Position
208 , hintTitle :: String
209 } deriving (Generic, ToJSON)