Skip to content

Commit 5b9892a

Browse files
fendorfendor
committed
Add Tests for the resolve - fallback
When resolving CodeActions, CodeLenses or Completions do not have a _data field but a client tries to resolve those items, HLS used to reject this request. To avoid this, we install a fallback handler which returns such items unmodified. We add tests to make sure this works as intended.
1 parent 86eeb5e commit 5b9892a

File tree

4 files changed

+215
-0
lines changed

4 files changed

+215
-0
lines changed

‎ghcide/test/exe/Config.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,8 @@ module Config(
55
mkIdeTestFs
66
, dummyPlugin
77

8+
-- * runners for testing specific plugins
9+
, testSessionWithPlugin
810
-- * runners for testing with dummy plugin
911
, runWithDummyPlugin
1012
, testWithDummyPlugin
@@ -34,6 +36,7 @@ import Control.Monad (unless)
3436
import Data.Foldable (traverse_)
3537
import Data.Function ((&))
3638
import qualified Data.Text as T
39+
import Development.IDE (Pretty)
3740
import Development.IDE.Test (canonicalizeUri)
3841
import Ide.Types (defaultPluginDescriptor)
3942
import qualified Language.LSP.Protocol.Lens as L
@@ -49,6 +52,16 @@ testDataDir = "ghcide" </> "test" </> "data"
4952
mkIdeTestFs :: [FS.FileTree] -> FS.VirtualFileTree
5053
mkIdeTestFs = FS.mkVirtualFileTree testDataDir
5154

55+
-- * Run with some injected plugin
56+
-- testSessionWithPlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a
57+
testSessionWithPlugin :: Pretty b => FS.VirtualFileTree -> PluginTestDescriptor b -> (FilePath -> Session a) -> IO a
58+
testSessionWithPlugin fs plugin = runSessionWithTestConfig def
59+
{ testPluginDescriptor = plugin
60+
, testDirLocation = Right fs
61+
, testConfigCaps = lspTestCaps
62+
, testShiftRoot = True
63+
}
64+
5265
-- * A dummy plugin for testing ghcIde
5366
dummyPlugin :: PluginTestDescriptor ()
5467
dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core"

‎ghcide/test/exe/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,7 @@ import PluginSimpleTests
5959
import PositionMappingTests
6060
import PreprocessorTests
6161
import ReferenceTests
62+
import ResolveTests
6263
import RootUriTests
6364
import SafeTests
6465
import SymlinkTests
@@ -98,6 +99,7 @@ main = do
9899
, AsyncTests.tests
99100
, ClientSettingsTests.tests
100101
, ReferenceTests.tests
102+
, ResolveTests.tests
101103
, GarbageCollectionTests.tests
102104
, HieDbRetry.tests
103105
, ExceptionTests.tests

‎ghcide/test/exe/ResolveTests.hs

Lines changed: 199 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,199 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE DerivingStrategies #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
module ResolveTests (tests) where
5+
6+
import Config
7+
import Control.Lens
8+
import Data.Aeson
9+
import qualified Data.Maybe as Maybe
10+
import Data.Text (Text)
11+
import qualified Data.Text as T
12+
import GHC.Generics
13+
import Ide.Logger
14+
import Ide.Types (PluginDescriptor (..), PluginId,
15+
defaultPluginDescriptor,
16+
mkPluginHandler,
17+
mkResolveHandler)
18+
import qualified Language.LSP.Protocol.Lens as J
19+
import qualified Language.LSP.Protocol.Lens as JL
20+
import Language.LSP.Protocol.Message (SomeMethod (..))
21+
import qualified Language.LSP.Protocol.Message as LSP
22+
import Language.LSP.Protocol.Types
23+
import Language.LSP.Test
24+
import Test.Hls (IdeState, SMethod (..), liftIO,
25+
mkPluginTestDescriptor,
26+
someMethodToMethodString,
27+
waitForAllProgressDone)
28+
import qualified Test.Hls.FileSystem as FS
29+
import Test.Tasty
30+
import Test.Tasty.HUnit
31+
32+
tests :: TestTree
33+
tests = testGroup "resolve"
34+
[ testGroup "with and without data" resolveRequests
35+
]
36+
37+
removeData :: JL.HasData_ s (Maybe a) => s -> s
38+
removeData param = param & JL.data_ .~ Nothing
39+
40+
simpleTestSession :: TestName -> Session () -> TestTree
41+
simpleTestSession name act =
42+
testCase name $ runWithResolvePlugin (mkIdeTestFs [FS.directCradle ["A.hs"]]) (const act)
43+
44+
runWithResolvePlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a
45+
runWithResolvePlugin fs =
46+
testSessionWithPlugin fs
47+
(mkPluginTestDescriptor resolvePluginDescriptor "resolve-plugin")
48+
49+
data CompletionItemResolveData = CompletionItemResolveData
50+
{ completionItemResolve_number :: Int
51+
}
52+
deriving stock (Show, Eq, Ord, Generic)
53+
deriving anyclass (ToJSON, FromJSON)
54+
55+
data CodeActionResolve = CodeActionResolve
56+
{ codeActionResolve_number :: Int
57+
}
58+
deriving stock (Show, Eq, Ord, Generic)
59+
deriving anyclass (ToJSON, FromJSON)
60+
61+
data CodeLensResolve = CodeLensResolve
62+
{ codeLensResolve_number :: Int
63+
}
64+
deriving stock (Show, Eq, Ord, Generic)
65+
deriving anyclass (ToJSON, FromJSON)
66+
67+
resolvePluginDescriptor :: Recorder (WithPriority Text) -> PluginId -> PluginDescriptor IdeState
68+
resolvePluginDescriptor recorder pid = (defaultPluginDescriptor pid "Test Plugin for Resolve Requests")
69+
{ pluginHandlers = mconcat
70+
[ mkResolveHandler LSP.SMethod_CompletionItemResolve $ \_ _ param _ CompletionItemResolveData{} -> pure param
71+
, mkPluginHandler LSP.SMethod_TextDocumentCompletion $ \_ _ _ -> do
72+
pure $ InL
73+
[ defCompletionItem "test item without data"
74+
, defCompletionItem "test item with data"
75+
& J.data_ .~ Just (toJSON $ CompletionItemResolveData 100)
76+
]
77+
, mkResolveHandler LSP.SMethod_CodeActionResolve $ \_ _ param _ CodeActionResolve{} -> pure param
78+
, mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ \_ _ _ -> do
79+
logWith recorder Debug "Why is the handler not called?"
80+
pure $ InL
81+
[ InR $ defCodeAction "test item without data"
82+
, InR $ defCodeAction "test item with data"
83+
& J.data_ .~ Just (toJSON $ CodeActionResolve 70)
84+
]
85+
, mkResolveHandler LSP.SMethod_CodeLensResolve $ \_ _ param _ CodeLensResolve{} -> pure param
86+
, mkPluginHandler LSP.SMethod_TextDocumentCodeLens $ \_ _ _ -> do
87+
pure $ InL
88+
[ defCodeLens "test item without data"
89+
, defCodeLens "test item with data"
90+
& J.data_ .~ Just (toJSON $ CodeLensResolve 50)
91+
]
92+
]
93+
}
94+
95+
resolveRequests :: [TestTree]
96+
resolveRequests =
97+
[ simpleTestSession "completion resolve" $ do
98+
doc <- createDoc "A.hs" "haskell" $ T.unlines
99+
[ "module A where"
100+
, "data Foo = Foo { foo :: Int }"
101+
, "bar = Foo 4"
102+
]
103+
waitForAllProgressDone
104+
items <- getCompletions doc (Position 2 7)
105+
let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items
106+
liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems)
107+
-- This must not throw an error.
108+
_ <- traverse (resolveCompletion . removeData) resolveCompItems
109+
pure ()
110+
, simpleTestSession "codeAction resolve" $ do
111+
doc <- createDoc "A.hs" "haskell" $ T.unlines
112+
[ "module A where"
113+
, "data Foo = Foo { foo :: Int }"
114+
, "bar = Foo 4"
115+
]
116+
waitForAllProgressDone
117+
-- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic
118+
-- locations and we don't have diagnostics in these tests.
119+
cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0))
120+
let resolveCas = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.title)) cas
121+
liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCas)
122+
-- This must not throw an error.
123+
_ <- traverse (resolveCodeAction . removeData) resolveCas
124+
pure ()
125+
, simpleTestSession "codelens resolve" $ do
126+
doc <- createDoc "A.hs" "haskell" $ T.unlines
127+
[ "module A where"
128+
, "data Foo = Foo { foo :: Int }"
129+
, "bar = Foo 4"
130+
]
131+
waitForAllProgressDone
132+
cd <- getCodeLenses doc
133+
let resolveCodeLenses = filter (\i -> case i ^. J.command of
134+
Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title)
135+
Nothing -> False
136+
) cd
137+
liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCodeLenses)
138+
-- This must not throw an error.
139+
_ <- traverse (resolveCodeLens . removeData) resolveCodeLenses
140+
pure ()
141+
]
142+
143+
defCompletionItem :: T.Text -> CompletionItem
144+
defCompletionItem lbl = CompletionItem
145+
{ _label = lbl
146+
, _labelDetails = Nothing
147+
, _kind = Nothing
148+
, _tags = Nothing
149+
, _detail = Nothing
150+
, _documentation = Nothing
151+
, _deprecated = Nothing
152+
, _preselect = Nothing
153+
, _sortText = Nothing
154+
, _filterText = Nothing
155+
, _insertText = Just "insertion"
156+
, _insertTextFormat = Nothing
157+
, _insertTextMode = Nothing
158+
, _textEdit = Nothing
159+
, _textEditText = Nothing
160+
, _additionalTextEdits = Nothing
161+
, _commitCharacters = Nothing
162+
, _command = Nothing
163+
, _data_ = Nothing
164+
}
165+
166+
defCodeAction :: T.Text -> CodeAction
167+
defCodeAction lbl = CodeAction
168+
{ _title = lbl
169+
, _kind = Just CodeActionKind_Refactor
170+
, _diagnostics = Nothing
171+
, _isPreferred = Nothing
172+
, _disabled = Nothing
173+
, _edit = Nothing
174+
, _command = Just $ Command
175+
{ _title = lbl
176+
, _command = lbl
177+
, _arguments = Nothing
178+
}
179+
, _data_ = Nothing
180+
}
181+
182+
defCodeLens :: T.Text -> CodeLens
183+
defCodeLens lbl = CodeLens
184+
{ _range = mkRange 0 0 1 0
185+
, _command = Just $ Command
186+
{ _title = lbl
187+
, _command = lbl
188+
, _arguments = Nothing
189+
}
190+
, _data_ = Nothing
191+
}
192+
193+
-- TODO: expose this from lsp-test
194+
resolveCompletion :: CompletionItem -> Session CompletionItem
195+
resolveCompletion item = do
196+
rsp <- request SMethod_CompletionItemResolve item
197+
case rsp ^. JL.result of
198+
Left err -> liftIO $ assertFailure (someMethodToMethodString (SomeMethod SMethod_CompletionItemResolve) <> " failed with: " <> show err)
199+
Right x -> pure x

‎haskell-language-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2208,6 +2208,7 @@ test-suite ghcide-tests
22082208
PreprocessorTests
22092209
Progress
22102210
ReferenceTests
2211+
ResolveTests
22112212
RootUriTests
22122213
SafeTests
22132214
SymlinkTests

0 commit comments

Comments
 (0)