1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
9 import qualified Data.HashMap.Strict as HM
11 import Control.Concurrent
12 import Control.Monad.IO.Class
13 import Control.Lens hiding (List)
15 import Language.Haskell.LSP.Messages
16 import Language.Haskell.LSP.Test
17 import Language.Haskell.LSP.Test.Replay
18 import Language.Haskell.LSP.TH.ClientCapabilities
19 import Language.Haskell.LSP.Types hiding (capabilities)
23 describe "manual session" $ do
25 runSession "hie --lsp" "test/data/renamePass" $ do
26 doc <- openDoc "Desktop/simple.hs" "haskell"
28 skipMany loggingNotification
32 rspSymbols <- getDocumentSymbols doc
35 let (List symbols) = fromJust (rspSymbols ^. result)
36 mainSymbol = head symbols
37 mainSymbol ^. name `shouldBe` "main"
38 mainSymbol ^. kind `shouldBe` SkFunction
39 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
40 mainSymbol ^. containerName `shouldBe` Nothing
43 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
44 let session = runSession "hie --lsp" "test/data/renamePass" $ do
45 openDoc "Desktop/simple.hs" "haskell"
46 skipMany loggingNotification
48 in session `shouldThrow` anyException
49 it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
50 rsp <- initializeResponse
51 liftIO $ rsp ^. result `shouldNotBe` Nothing
53 it "can register specific capabilities" $ do
54 let caps = def { _workspace = Just workspaceCaps }
55 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
56 configCaps = DidChangeConfigurationClientCapabilities (Just True)
57 conf = def { capabilities = caps }
58 runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
60 describe "exceptions" $ do
61 it "throw on time out" $
62 let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
63 skipMany loggingNotification
64 _ <- request :: Session ApplyWorkspaceEditRequest
66 in sesh `shouldThrow` anySessionException
68 it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 5}) "hie --lsp" "test/data/renamePass" $ do
70 liftIO $ threadDelay 10
71 _ <- openDoc "Desktop/simple.hs" "haskell"
74 it "throw when there's an unexpected message" $
75 let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
77 in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
79 it "throw when there's an unexpected message 2" $
80 let selector (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True
83 doc <- openDoc "Desktop/simple.hs" "haskell"
84 sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
85 skipMany anyNotification
86 response :: Session RenameResponse -- the wrong type
87 in runSession "hie --lsp" "test/data/renamePass" sesh
88 `shouldThrow` selector
90 describe "replay session" $ do
92 replaySession "hie --lsp" "test/data/renamePass"
94 let selector (ReplayOutOfOrderException _ _) = True
96 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
98 describe "manual javascript session" $
100 runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
101 doc <- openDoc "test.js" "javascript"
105 rspSymbols <- getDocumentSymbols doc
107 let (List symbols) = fromJust (rspSymbols ^. result)
108 fooSymbol = head symbols
110 fooSymbol ^. name `shouldBe` "foo"
111 fooSymbol ^. kind `shouldBe` SkFunction
113 describe "text document VFS" $
114 it "sends back didChange notifications" $
115 runSession "hie --lsp" "test/data/refactor" $ do
116 doc <- openDoc "Main.hs" "haskell"
118 let args = toJSON $ AOP (doc ^. uri)
121 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
122 sendRequest WorkspaceExecuteCommand reqParams
123 skipMany anyNotification
124 _ <- response :: Session ExecuteCommandResponse
126 editReq <- request :: Session ApplyWorkspaceEditRequest
128 let (Just cs) = editReq ^. params . edit . changes
129 [(u, List es)] = HM.toList cs
130 u `shouldBe` doc ^. uri
131 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
135 contents <- documentContents doc
136 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
138 describe "documentEdit" $
139 it "automatically consumes applyedit requests" $
140 runSession "hie --lsp" "test/data/refactor" $ do
141 doc <- openDoc "Main.hs" "haskell"
143 let args = toJSON $ AOP (doc ^. uri)
146 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
147 sendRequest WorkspaceExecuteCommand reqParams
148 skipMany anyNotification
149 _ <- response :: Session ExecuteCommandResponse
151 contents <- getDocumentEdit doc
152 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
157 data ApplyOneParams = AOP
159 , start_pos :: Position
160 , hintTitle :: String
161 } deriving (Generic, ToJSON)