@@ -30,11 +30,74 @@ main = defaultMain $ testGroup "HIE"
3030 void (message :: Session ProgressStartNotification)
3131 closeDoc doc
3232 void (message :: Session ProgressDoneNotification)
33+ , initializeResponseTests
3334 , diagnosticTests
3435 , codeActionTests
3536 , findDefinitionTests
3637 ]
3738
39+initializeResponseTests :: TestTree
40+initializeResponseTests = withResource acquire release tests where
41+
42+ -- these tests document and monitor the evolution of the
43+ -- capabilities announced by the server in the initialize
44+ -- response. Currently the server advertises almost no capabilities
45+ -- at all, in some cases failing to announce capabilities that it
46+ -- actually does provide! Hopefully this will change ...
47+ tests :: IO InitializeResponse -> TestTree
48+ tests getInitializeResponse =
49+ testGroup "initialize response capabilities"
50+ [ chk " text doc sync" _textDocumentSync tds
51+ , chk " hover" _hoverProvider (Just True)
52+ , chk "NO completion" _completionProvider Nothing
53+ , chk "NO signature help" _signatureHelpProvider Nothing
54+ , chk " goto definition" _definitionProvider (Just True)
55+ , chk "NO goto type definition" _typeDefinitionProvider Nothing
56+ , chk "NO goto implementation" _implementationProvider Nothing
57+ , chk "NO find references" _referencesProvider Nothing
58+ , chk "NO doc highlight" _documentHighlightProvider Nothing
59+ , chk "NO doc symbol" _documentSymbolProvider Nothing
60+ , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
61+ , chk "NO code action" _codeActionProvider Nothing -- available but not declared !
62+ , chk "NO code lens" _codeLensProvider Nothing
63+ , chk "NO doc formatting" _documentFormattingProvider Nothing
64+ , chk "NO doc range formatting"
65+ _documentRangeFormattingProvider Nothing
66+ , chk "NO doc formatting on typing"
67+ _documentOnTypeFormattingProvider Nothing
68+ , chk "NO renaming" _renameProvider Nothing
69+ , chk "NO doc link" _documentLinkProvider Nothing
70+ , chk "NO color" _colorProvider Nothing
71+ , chk "NO folding range" _foldingRangeProvider Nothing
72+ , chk "NO execute command" _executeCommandProvider Nothing
73+ , chk "NO workspace" _workspace nothingWorkspace
74+ , chk "NO experimental" _experimental Nothing
75+ ] where
76+
77+ tds = Just (TDSOptions (TextDocumentSyncOptions
78+ { _openClose = Just True
79+ , _change = Just TdSyncIncremental
80+ , _willSave = Nothing
81+ , _willSaveWaitUntil = Nothing
82+ , _save = Just (SaveOptions {_includeText = Nothing})}))
83+
84+ nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
85+
86+ chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
87+ chk title getActual expected =
88+ testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
89+
90+ innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
91+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
92+ innerCaps _ = error "this test only expects inner capabilities"
93+
94+ acquire :: IO InitializeResponse
95+ acquire = run initializeResponse
96+
97+ release :: InitializeResponse -> IO ()
98+ release = const $ pure ()
99+
100+
38101diagnosticTests :: TestTree
39102diagnosticTests = testGroup "diagnostics"
40103 [ testSession "fix syntax error" $ do