forked from haskell/haskell-language-server
/
AbstractLSP.hs
270 lines (242 loc) · 9.18 KB
/
AbstractLSP.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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Wingman.AbstractLSP (installInteractions) where
import Control.Monad (void)
import Control.Monad.IO.Class
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import qualified Data.Aeson as A
import Data.Coerce
import Data.Foldable (traverse_)
import Data.Monoid (Last (..))
import qualified Data.Text as T
import Data.Traversable (for)
import Data.Tuple.Extra (uncurry3)
import Development.IDE (IdeState)
import Development.IDE.Core.UseStale
import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource))
import qualified Ide.Plugin.Config as Plugin
import Ide.Types
import Language.LSP.Server (LspM, sendRequest, getClientCapabilities)
import qualified Language.LSP.Types as LSP
import Language.LSP.Types hiding (CodeLens, CodeAction)
import Wingman.AbstractLSP.Types
import Wingman.EmptyCase (fromMaybeT)
import Wingman.LanguageServer (getTacticConfig, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams)
import Wingman.Types
------------------------------------------------------------------------------
-- | Attact the 'Interaction's to a 'PluginDescriptor'. Interactions are
-- self-contained request/response pairs that abstract over the LSP, and
-- provide a unified interface for doing interesting things, without needing to
-- dive into the underlying API too directly.
installInteractions
:: [Interaction]
-> PluginDescriptor IdeState
-> PluginDescriptor IdeState
installInteractions is desc =
let plId = pluginId desc
in desc
{ pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is
, pluginHandlers = pluginHandlers desc <> buildHandlers is
}
------------------------------------------------------------------------------
-- | Extract 'PluginHandlers' from 'Interaction's.
buildHandlers
:: [Interaction]
-> PluginHandlers IdeState
buildHandlers cs =
flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) ->
case c_makeCommand c of
SynthesizeCodeAction k ->
mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k
SynthesizeCodeLens k ->
mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k
------------------------------------------------------------------------------
-- | Extract a 'PluginCommand' from an 'Interaction'.
buildCommand
:: PluginId
-> Interaction
-> PluginCommand IdeState
buildCommand plId (Interaction (c :: Continuation sort target b)) =
PluginCommand
{ commandId = toCommandId $ c_sort c
, commandDesc = T.pack ""
, commandFunc = runContinuation plId c
}
------------------------------------------------------------------------------
-- | Boilerplate for running a 'Continuation' as part of an LSP command.
runContinuation
:: forall sort a b
. IsTarget a
=> PluginId
-> Continuation sort a b
-> CommandFunction IdeState (FileContext, b)
runContinuation plId cont state (fc, b) = do
fromMaybeT
(Left $ ResponseError
{ _code = InternalError
, _message = T.pack "TODO(sandy)"
, _xdata = Nothing
} ) $ do
env@LspEnv{..} <- buildEnv state plId fc
let stale a = runStaleIde "runContinuation" state (fc_nfp le_fileContext) a
args <- fetchTargetArgs @a env
res <- c_runCommand cont env args fc b
-- This block returns a maybe error.
fmap (maybe (Right $ A.Null) Left . coerce . foldMap Last) $
for res $ \case
ErrorMessages errs -> do
traverse_ showUserFacingMessage errs
pure Nothing
RawEdit edits -> do
sendEdits edits
pure Nothing
GraftEdit gr -> do
ccs <- lift getClientCapabilities
TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
case mkWorkspaceEdits le_dflags ccs (fc_uri le_fileContext) (unTrack pm) gr of
Left errs ->
pure $ Just $ ResponseError
{ _code = InternalError
, _message = T.pack $ show errs
, _xdata = Nothing
}
Right edits -> do
sendEdits edits
pure $ Nothing
------------------------------------------------------------------------------
-- | Push a 'WorkspaceEdit' to the client.
sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) ()
sendEdits edits =
void $ lift $
sendRequest
SWorkspaceApplyEdit
(ApplyWorkspaceEditParams Nothing edits)
(const $ pure ())
------------------------------------------------------------------------------
-- | Push a 'UserFacingMessage' to the client.
showUserFacingMessage
:: UserFacingMessage
-> MaybeT (LspM Plugin.Config) ()
showUserFacingMessage ufm =
void $ lift $ showLspMessage $ mkShowMessageParams ufm
------------------------------------------------------------------------------
-- | Build an 'LspEnv', which contains the majority of things we need to know
-- in a 'Continuation'.
buildEnv
:: IdeState
-> PluginId
-> FileContext
-> MaybeT (LspM Plugin.Config) LspEnv
buildEnv state plId fc = do
cfg <- lift $ getTacticConfig plId
dflags <- mapMaybeT liftIO $ getIdeDynflags state $ fc_nfp fc
pure $ LspEnv
{ le_ideState = state
, le_pluginId = plId
, le_dflags = dflags
, le_config = cfg
, le_fileContext = fc
}
------------------------------------------------------------------------------
-- | Lift a 'Continuation' into an LSP CodeAction.
codeActionProvider
:: forall target sort b
. (IsContinuationSort sort, A.ToJSON b, IsTarget target)
=> sort
-> ( LspEnv
-> TargetArgs target
-> MaybeT (LspM Plugin.Config) [(Metadata, b)]
)
-> PluginMethodHandler IdeState TextDocumentCodeAction
codeActionProvider sort k state plId
(CodeActionParams _ _ (TextDocumentIdentifier uri) range _)
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
fromMaybeT (Right $ List []) $ do
let fc = FileContext
{ fc_uri = uri
, fc_nfp = nfp
, fc_range = Just $ unsafeMkCurrent range
}
env <- buildEnv state plId fc
args <- fetchTargetArgs @target env
actions <- k env args
pure
$ Right
$ List
$ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions
codeActionProvider _ _ _ _ _ = pure $ Right $ List []
------------------------------------------------------------------------------
-- | Lift a 'Continuation' into an LSP CodeLens.
codeLensProvider
:: forall target sort b
. (IsContinuationSort sort, A.ToJSON b, IsTarget target)
=> sort
-> ( LspEnv
-> TargetArgs target
-> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]
)
-> PluginMethodHandler IdeState TextDocumentCodeLens
codeLensProvider sort k state plId
(CodeLensParams _ _ (TextDocumentIdentifier uri))
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
fromMaybeT (Right $ List []) $ do
let fc = FileContext
{ fc_uri = uri
, fc_nfp = nfp
, fc_range = Nothing
}
env <- buildEnv state plId fc
args <- fetchTargetArgs @target env
actions <- k env args
pure
$ Right
$ List
$ fmap (uncurry3 $ makeCodeLens plId sort fc) actions
codeLensProvider _ _ _ _ _ = pure $ Right $ List []
------------------------------------------------------------------------------
-- | Build a 'LSP.CodeAction'.
makeCodeAction
:: (A.ToJSON b, IsContinuationSort sort)
=> PluginId
-> FileContext
-> sort
-> Metadata
-> b
-> LSP.CodeAction
makeCodeAction plId fc sort (Metadata title kind preferred) b =
let cmd_id = toCommandId sort
cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)]
in LSP.CodeAction
{ _title = title
, _kind = Just kind
, _diagnostics = Nothing
, _isPreferred = Just preferred
, _disabled = Nothing
, _edit = Nothing
, _command = Just cmd
, _xdata = Nothing
}
------------------------------------------------------------------------------
-- | Build a 'LSP.CodeLens'.
makeCodeLens
:: (A.ToJSON b, IsContinuationSort sort)
=> PluginId
-> sort
-> FileContext
-> Range
-> Metadata
-> b
-> LSP.CodeLens
makeCodeLens plId sort fc range (Metadata title _ _) b =
let fc' = fc { fc_range = Just $ unsafeMkCurrent range }
cmd_id = toCommandId sort
cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)]
in LSP.CodeLens
{ _range = range
, _command = Just cmd
, _xdata = Nothing
}