forked from haskell/haskell-language-server
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathDeferred.hs
177 lines (156 loc) · 8.29 KB
/
Deferred.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module Deferred(tests) where
import Control.Applicative.Combinators
import Control.Monad.IO.Class
import Control.Lens hiding (List)
-- import Control.Monad
-- import Data.Maybe
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens hiding (id, message)
-- import qualified Language.Haskell.LSP.Types.Lens as LSP
import Test.Hls.Util
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit
import Test.Hspec.Expectations
tests :: TestTree
tests = testGroup "deferred responses" [
--TODO: DOes not compile
-- testCase "do not affect hover requests" $ runSession hieCommand fullCaps "test/testdata" $ do
-- doc <- openDoc "FuncTest.hs" "haskell"
-- id1 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing)
-- skipMany anyNotification
-- hoverRsp <- message :: Session HoverResponse
-- liftIO $ hoverRsp ^? result . _Just . _Just . contents `shouldBe` Nothing
-- liftIO $ hoverRsp ^. LSP.id `shouldBe` responseId id1
-- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
-- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse
-- liftIO $ symbolsRsp ^. LSP.id `shouldBe` responseId id2
-- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing)
-- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse
-- liftIO $ hoverRsp2 ^. LSP.id `shouldBe` responseId id3
-- let contents2 = hoverRsp2 ^? result . _Just . _Just . contents
-- liftIO $ contents2 `shouldNotSatisfy` null
-- -- Now that we have cache the following request should be instant
-- let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing
-- highlightRsp <- request TextDocumentDocumentHighlight highlightParams
-- let (Just (List locations)) = highlightRsp ^. result
-- liftIO $ locations `shouldBe` [ DocumentHighlight
-- { _range = Range
-- { _start = Position {_line = 7, _character = 0}
-- , _end = Position {_line = 7, _character = 2}
-- }
-- , _kind = Just HkWrite
-- }
-- , DocumentHighlight
-- { _range = Range
-- { _start = Position {_line = 7, _character = 0}
-- , _end = Position {_line = 7, _character = 2}
-- }
-- , _kind = Just HkWrite
-- }
-- , DocumentHighlight
-- { _range = Range
-- { _start = Position {_line = 5, _character = 6}
-- , _end = Position {_line = 5, _character = 8}
-- }
-- , _kind = Just HkRead
-- }
-- , DocumentHighlight
-- { _range = Range
-- { _start = Position {_line = 7, _character = 0}
-- , _end = Position {_line = 7, _character = 2}
-- }
-- , _kind = Just HkWrite
-- }
-- , DocumentHighlight
-- { _range = Range
-- { _start = Position {_line = 7, _character = 0}
-- , _end = Position {_line = 7, _character = 2}
-- }
-- , _kind = Just HkWrite
-- }
-- , DocumentHighlight
-- { _range = Range
-- { _start = Position {_line = 5, _character = 6}
-- , _end = Position {_line = 5, _character = 8}
-- }
-- , _kind = Just HkRead
-- }
-- ]
testCase "instantly respond to failed modules with no cache" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "FuncTestFail.hs" "haskell"
defs <- getDefinitions doc (Position 1 11)
liftIO $ defs `shouldBe` []
-- TODO: the benefits of caching parsed modules is doubted.
-- TODO: add issue link
-- , testCase "respond to untypecheckable modules with parsed module cache" $
-- runSession hieCommand fullCaps "test/testdata" $ do
-- doc <- openDoc "FuncTestFail.hs" "haskell"
-- (Left (sym:_)) <- getDocumentSymbols doc
-- liftIO $ sym ^. name `shouldBe` "main"
-- TODO does not compile
-- , testCase "returns hints as diagnostics" $ runSession hieCommand fullCaps "test/testdata" $ do
-- _ <- openDoc "FuncTest.hs" "haskell"
-- cwd <- liftIO getCurrentDirectory
-- let testUri = filePathToUri $ cwd </> "test/testdata/FuncTest.hs"
-- diags <- skipManyTill loggingNotification publishDiagnosticsNotification
-- liftIO $ diags ^? params `shouldBe` (Just $ PublishDiagnosticsParams
-- { _uri = testUri
-- , _diagnostics = List
-- [ Diagnostic
-- (Range (Position 9 6) (Position 10 18))
-- (Just DsInfo)
-- (Just (StringValue "Redundant do"))
-- (Just "hlint")
-- "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n"
-- Nothing
-- ]
-- }
-- )
-- let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)]
-- args = List [Object args']
--
-- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing)
-- liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty)
-- editReq <- message :: Session ApplyWorkspaceEditRequest
-- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
-- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits]
-- liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit
-- Nothing
-- (Just expectedTextDocEdits)
-- , multiServerTests
, multiMainTests
]
--TODO: Does not compile
-- multiServerTests :: TestTree
-- multiServerTests = testGroup "multi-server setup" [
-- testCase "doesn't have clashing commands on two servers" $ do
-- let getCommands = runSession hieCommand fullCaps "test/testdata" $ do
-- rsp <- initializeResponse
-- let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
-- return $ fromJust uuids
-- List uuids1 <- getCommands
-- List uuids2 <- getCommands
-- liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe)
-- ]
multiMainTests :: TestTree
multiMainTests = testGroup "multiple main modules" [
ignoreTestBecause "Broken: Unexpected ConduitParser.empty" $
testCase "Can load one file at a time, when more than one Main module exists"
$ runSession hieCommand fullCaps "test/testdata" $ do
_doc <- openDoc "ApplyRefact2.hs" "haskell"
_diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
let (List diags) = diagsRspGhc ^. params . diagnostics
liftIO $ length diags `shouldBe` 2
_doc2 <- openDoc "HaReRename.hs" "haskell"
_diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
-- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification
diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
let (List diags2) = diagsRsp2 ^. params . diagnostics
liftIO $ show diags2 `shouldBe` "[]"
]