Skip to content

Commit 3cf52e1

Browse files
banacornbanacorn
committed
[ fix ] Restore request handlers with lsp >= 2
1 parent e0c3f02 commit 3cf52e1

File tree

2 files changed

+98
-24
lines changed

2 files changed

+98
-24
lines changed

‎src/Server.hs‎

Lines changed: 67 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ import Language.LSP.Server hiding ( Options )
2121
#if MIN_VERSION_lsp(2,0,0)
2222
import Language.LSP.Protocol.Message ( pattern RequestMessage
2323
, SMethod( SMethod_CustomMethod, SMethod_TextDocumentHover)
24+
, pattern TRequestMessage
2425
)
2526
import Language.LSP.Protocol.Types ( TextDocumentSyncOptions(..)
2627
, TextDocumentSyncKind( TextDocumentSyncKind_Incremental )
@@ -29,6 +30,7 @@ import Language.LSP.Protocol.Types ( TextDocumentSyncOptions(..)
2930
, pattern TextDocumentIdentifier
3031
, pattern HoverParams
3132
, pattern InR
33+
, pattern InL
3234
)
3335
#else
3436
import Language.LSP.Types
@@ -47,7 +49,6 @@ import qualified Server.Handler as Handler
4749
import qualified Language.LSP.Server as LSP
4850
import Options
4951

50-
5152
--------------------------------------------------------------------------------
5253

5354
run :: Options -> IO Int
@@ -70,28 +71,79 @@ run options = do
7071
Nothing -> do
7172
runServer (serverDefn options)
7273
where
74+
-- serverDefn :: Options -> ServerDefinition Config
75+
-- serverDefn options =
76+
-- ServerDefinition
77+
-- { defaultConfig = initConfig,
78+
-- #if MIN_VERSION_lsp_types(2,0,0)
79+
-- onConfigChange = \old newRaw -> pure (),
80+
-- #else
81+
-- onConfigurationChange = \old newRaw -> case JSON.fromJSON newRaw of
82+
-- JSON.Error s -> Left $ pack $ "Cannot parse server configuration: " <> s
83+
-- JSON.Success new -> Right new,
84+
-- #endif
85+
-- doInitialize = \ctxEnv _req -> do
86+
-- env <- runLspT ctxEnv (createInitEnv options)
87+
-- switchboard <- Switchboard.new env
88+
-- Switchboard.setupLanguageContextEnv switchboard ctxEnv
89+
-- #if MIN_VERSION_lsp_types(2,0,0)
90+
-- pure $ Right (ctxEnv),
91+
-- #else
92+
-- pure $ Right (ctxEnv, env),
93+
-- #endif
94+
-- #if MIN_VERSION_lsp_types(2,0,0)
95+
-- interpretHandler = \env -> Iso {
96+
-- forward = runLspT env, -- how to convert from IO ~> m
97+
-- backward = liftIO -- how to convert from m ~> IO
98+
-- },
99+
-- #else
100+
-- staticHandlers = handlers,
101+
-- interpretHandler = \(ctxEnv, env) ->
102+
-- Iso (runLspT ctxEnv . runServerM env) liftIO,
103+
-- #endif
104+
-- options = lspOptions
105+
-- }
106+
107+
#if MIN_VERSION_lsp_types(2,0,0)
108+
serverDefn :: Options -> ServerDefinition Config
109+
serverDefn options =
110+
ServerDefinition
111+
{
112+
defaultConfig = initConfig,
113+
onConfigChange = const $ pure (),
114+
parseConfig = \old newRaw -> case JSON.fromJSON newRaw of
115+
JSON.Error s -> Left $ pack $ "Cannot parse server configuration: " <> s
116+
JSON.Success new -> Right new,
117+
doInitialize = \ctxEnv _req -> do
118+
env <- runLspT ctxEnv (createInitEnv options)
119+
switchboard <- Switchboard.new env
120+
Switchboard.setupLanguageContextEnv switchboard ctxEnv
121+
pure $ Right (ctxEnv, env),
122+
configSection = "dummy",
123+
#else
73124
serverDefn :: Options -> ServerDefinition Config
74125
serverDefn options =
75126
ServerDefinition
76127
{ defaultConfig = initConfig,
77-
#if MIN_VERSION_lsp_types(2,0,0)
78-
onConfigChange = \old newRaw -> (),
79-
-- case JSON.fromJSON newRaw of
80-
-- JSON.Error s -> () -- putStrLn $ pack $ "Cannot parse server configuration: " <> s
81-
-- JSON.Success new -> (),
82-
#else
83128
onConfigurationChange = \old newRaw -> case JSON.fromJSON newRaw of
84129
JSON.Error s -> Left $ pack $ "Cannot parse server configuration: " <> s
85130
JSON.Success new -> Right new,
86-
#endif
87131
doInitialize = \ctxEnv _req -> do
88132
env <- runLspT ctxEnv (createInitEnv options)
89133
switchboard <- Switchboard.new env
90134
Switchboard.setupLanguageContextEnv switchboard ctxEnv
91135
pure $ Right (ctxEnv, env),
92-
-- staticHandlers = handlers,
93-
-- interpretHandler = \(ctxEnv, env) ->
94-
-- Iso (runLspT ctxEnv . runServerM env) liftIO,
136+
#endif
137+
#if MIN_VERSION_lsp_types(2,0,0)
138+
staticHandlers = const handlers,
139+
#else
140+
staticHandlers = handlers,
141+
#endif
142+
interpretHandler = \(ctxEnv, env) ->
143+
Iso {
144+
forward = runLspT ctxEnv . runServerM env,
145+
backward = liftIO
146+
},
95147
options = lspOptions
96148
}
97149

@@ -130,22 +182,22 @@ handlers = mconcat
130182
[ -- custom methods, not part of LSP
131183
requestHandler agdaCustomMethod $ \ req responder -> do
132184
#if MIN_VERSION_lsp_types(2,0,0)
133-
return ()
185+
let TRequestMessage _ _i _ params = req
134186
#else
135187
let RequestMessage _ _i _ params = req
188+
#endif
136189
response <- Agda.sendCommand params
137190
responder $ Right response
138-
#endif
139191
,
140192
-- hover provider
141193
requestHandler hoverMethod $ \ req responder -> do
142194
#if MIN_VERSION_lsp_types(2,0,0)
143-
return ()
195+
let TRequestMessage _ _ _ (HoverParams (TextDocumentIdentifier uri) pos _workDone) = req
144196
#else
145197
let RequestMessage _ _ _ (HoverParams (TextDocumentIdentifier uri) pos _workDone) = req
198+
#endif
146199
result <- Handler.onHover uri pos
147200
responder $ Right result
148-
#endif
149201
-- -- syntax highlighting
150202
-- , requestHandler STextDocumentSemanticTokensFull $ \req responder -> do
151203
-- result <- Handler.onHighlight (req ^. (params . textDocument . uri))

‎src/Server/Handler.hs‎

Lines changed: 31 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -107,40 +107,62 @@ inferTypeOfText filepath text = runCommandM $ do
107107

108108
render <$> prettyATop typ
109109

110+
#if MIN_VERSION_lsp_types(2,0,0)
111+
onHover :: LSP.Uri -> LSP.Position -> ServerM (LspM Config) (LSP.Hover LSP.|? LSP.Null)
112+
#else
110113
onHover :: LSP.Uri -> LSP.Position -> ServerM (LspM Config) (Maybe LSP.Hover)
114+
#endif
111115
onHover uri pos = do
112116
result <- LSP.getVirtualFile (LSP.toNormalizedUri uri)
113117
case result of
114-
Nothing -> return Nothing
118+
#if MIN_VERSION_lsp_types(2,0,0)
119+
Nothing -> return $ LSP.InR LSP.Null
120+
#else
121+
Nothing -> return Nothing
122+
#endif
115123
Just file -> do
116124
let source = VFS.virtualFileText file
117125
let offsetTable = makeToOffset source
118126
let agdaPos = toAgdaPositionWithoutFile offsetTable pos
119127
lookupResult <- Parser.tokenAt uri source agdaPos
120128
case lookupResult of
121-
Nothing -> return Nothing
129+
#if MIN_VERSION_lsp_types(2,0,0)
130+
Nothing -> return $ LSP.InR LSP.Null
131+
#else
132+
Nothing -> return Nothing
133+
#endif
122134
Just (_token, text) -> do
123135
case LSP.uriToFilePath uri of
136+
#if MIN_VERSION_lsp_types(2,0,0)
137+
Nothing -> return $ LSP.InR LSP.Null
138+
#else
124139
Nothing -> return Nothing
140+
#endif
125141
Just filepath -> do
126142
let range = LSP.Range pos pos
127-
128143
inferResult <- inferTypeOfText filepath text
129144
case inferResult of
130145
Left err -> do
131146
let content = hoverContent $ "Error: " <> pack err
132-
return $ Just $ LSP.Hover content (Just range)
147+
#if MIN_VERSION_lsp_types(2,0,0)
148+
return $ LSP.InL $ LSP.Hover content (Just range)
149+
#else
150+
return $ Just $ LSP.Hover content (Just range)
151+
#endif
133152
Right typeString -> do
134153
let content = hoverContent $ pack typeString
135-
return $ Just $ LSP.Hover content (Just range)
154+
#if MIN_VERSION_lsp_types(2,0,0)
155+
return $ LSP.InL $ LSP.Hover content (Just range)
156+
#else
157+
return $ Just $ LSP.Hover content (Just range)
158+
#endif
136159
where
137-
hoverContent =
160+
hoverContent =
138161
#if MIN_VERSION_lsp_types(2,0,0)
139-
LSP.InL . LSP.mkMarkdownCodeBlock "agda-language-server"
162+
LSP.InL . LSP.mkMarkdownCodeBlock "agda-language-server"
140163
#else
141-
LSP.HoverContents . LSP.markedUpContent "agda-language-server"
164+
LSP.HoverContents . LSP.markedUpContent "agda-language-server"
142165
#endif
143-
144166
--------------------------------------------------------------------------------
145167
-- Helper functions for converting stuff to SemanticTokenAbsolute
146168

0 commit comments

Comments
 (0)