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
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 -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
26 let session = runSession "hie --lsp" "test/data/renamePass" $ do
27 openDoc "Desktop/simple.hs" "haskell"
28 skipMany loggingNotification
30 in session `shouldThrow` anyException
31 it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
32 rsp <- initializeResponse
33 liftIO $ rsp ^. result `shouldNotBe` Nothing
35 it "can register specific capabilities" $ do
36 let caps = def { _workspace = Just workspaceCaps }
37 workspaceCaps = def { _didChangeConfiguration = Just configCaps }
38 configCaps = DidChangeConfigurationClientCapabilities (Just True)
39 conf = def { capabilities = caps }
40 runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
42 describe "exceptions" $ do
43 it "throw on time out" $
44 let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
45 skipMany loggingNotification
46 _ <- request :: Session ApplyWorkspaceEditRequest
48 in sesh `shouldThrow` anySessionException
50 it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 5}) "hie --lsp" "test/data/renamePass" $ do
52 liftIO $ threadDelay 10
53 _ <- openDoc "Desktop/simple.hs" "haskell"
56 it "throw when there's an unexpected message" $
57 let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
59 in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
61 it "throw when there's an unexpected message 2" $
62 let selector (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True
65 doc <- openDoc "Desktop/simple.hs" "haskell"
66 sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc)
67 skipMany anyNotification
68 response :: Session RenameResponse -- the wrong type
69 in runSession "hie --lsp" "test/data/renamePass" sesh
70 `shouldThrow` selector
72 describe "replay session" $ do
74 replaySession "hie --lsp" "test/data/renamePass"
76 let selector (ReplayOutOfOrderException _ _) = True
78 in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
80 describe "manual javascript session" $
82 runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
83 doc <- openDoc "test.js" "javascript"
87 (fooSymbol:_) <- getDocumentSymbols doc
90 fooSymbol ^. name `shouldBe` "foo"
91 fooSymbol ^. kind `shouldBe` SkFunction
93 describe "text document VFS" $
94 it "sends back didChange notifications" $
95 runSession "hie --lsp" "test/data/refactor" $ do
96 doc <- openDoc "Main.hs" "haskell"
98 let args = toJSON $ AOP (doc ^. uri)
101 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
102 sendRequest_ WorkspaceExecuteCommand reqParams
104 editReq <- request :: Session ApplyWorkspaceEditRequest
106 let (Just cs) = editReq ^. params . edit . changes
107 [(u, List es)] = HM.toList cs
108 u `shouldBe` doc ^. uri
109 es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
113 contents <- documentContents doc
114 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
116 describe "documentEdit" $
117 it "automatically consumes applyedit requests" $
118 runSession "hie --lsp" "test/data/refactor" $ do
119 doc <- openDoc "Main.hs" "haskell"
121 let args = toJSON $ AOP (doc ^. uri)
124 reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
125 sendRequest_ WorkspaceExecuteCommand reqParams
126 contents <- getDocumentEdit doc
127 liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
130 describe "getAllCodeActions" $
131 it "works" $ runSession "hie --lsp" "test/data/refactor" $ do
132 doc <- openDoc "Main.hs" "haskell"
133 _ <- waitForDiagnostics
134 actions <- getAllCodeActions doc
136 let [CommandOrCodeActionCommand action] = actions
137 action ^. title `shouldBe` "Apply hint:Redundant bracket"
138 action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"
140 describe "getDocumentSymbols" $
141 it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do
142 doc <- openDoc "Desktop/simple.hs" "haskell"
144 skipMany loggingNotification
148 (mainSymbol:_) <- getDocumentSymbols doc
151 mainSymbol ^. name `shouldBe` "main"
152 mainSymbol ^. kind `shouldBe` SkFunction
153 mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
154 mainSymbol ^. containerName `shouldBe` Nothing
158 data ApplyOneParams = AOP
160 , start_pos :: Position
161 , hintTitle :: String
162 } deriving (Generic, ToJSON)