Skip to content

Commit 5d83b63

Browse files
isovectormergify[bot]
isovector
and
mergify[bot]
authored
Wingman: New AbstractLSP interface (#2094)
* WIP abstract LSP, take the pain out of writing LSP stuff * Finish making commands * Separate code lenses and actions * Pull out types * Finalize the abstract API * Bug fix in JSON; first connected abstract handler * Add ContinuationResult for better control over how edits work * Remove IO from TacticProviders; use LspEnv instead * installInteractions * Pull TacticCodeActions into their own file * Misc cleanup * Haddock * Fix bug in codelens * Port EmptyCase to Interaction * Rename makeTacticCodeAction -> makeTacticInteraction Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 903fe64 commit 5d83b63

File tree

8 files changed

+681
-351
lines changed

8 files changed

+681
-351
lines changed

‎plugins/hls-tactics-plugin/hls-tactics-plugin.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,9 @@ library
2727
hs-source-dirs: src
2828
exposed-modules:
2929
Ide.Plugin.Tactic
30+
Wingman.AbstractLSP
31+
Wingman.AbstractLSP.TacticActions
32+
Wingman.AbstractLSP.Types
3033
Wingman.Auto
3134
Wingman.CaseSplit
3235
Wingman.CodeGen

‎plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs

+1-5
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,5 @@
11
-- | A plugin that uses tactics to synthesize code
2-
module Ide.Plugin.Tactic
3-
( descriptor
4-
, tacticTitle
5-
, TacticCommand (..)
6-
) where
2+
module Ide.Plugin.Tactic (descriptor) where
73

84
import Wingman.Plugin
95

‎plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs

+263
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,263 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE StandaloneDeriving #-}
4+
5+
{-# LANGUAGE NoMonoLocalBinds #-}
6+
7+
{-# OPTIONS_GHC -Wno-orphans #-}
8+
9+
module Wingman.AbstractLSP (installInteractions) where
10+
11+
import Control.Monad (void)
12+
import Control.Monad.IO.Class
13+
import Control.Monad.Trans (lift)
14+
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
15+
import qualified Data.Aeson as A
16+
import Data.Foldable (traverse_)
17+
import qualified Data.Text as T
18+
import Data.Tuple.Extra (uncurry3)
19+
import Development.IDE (IdeState)
20+
import Development.IDE.Core.UseStale
21+
import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource))
22+
import qualified Ide.Plugin.Config as Plugin
23+
import Ide.Types
24+
import Language.LSP.Server (LspM, sendRequest, getClientCapabilities)
25+
import qualified Language.LSP.Types as LSP
26+
import Language.LSP.Types hiding (CodeLens, CodeAction)
27+
import Wingman.AbstractLSP.Types
28+
import Wingman.EmptyCase (fromMaybeT)
29+
import Wingman.LanguageServer (getTacticConfig, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams)
30+
import Wingman.Types
31+
32+
33+
------------------------------------------------------------------------------
34+
-- | Attact the 'Interaction's to a 'PluginDescriptor'. Interactions are
35+
-- self-contained request/response pairs that abstract over the LSP, and
36+
-- provide a unified interface for doing interesting things, without needing to
37+
-- dive into the underlying API too directly.
38+
installInteractions
39+
:: [Interaction]
40+
-> PluginDescriptor IdeState
41+
-> PluginDescriptor IdeState
42+
installInteractions is desc =
43+
let plId = pluginId desc
44+
in desc
45+
{ pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is
46+
, pluginHandlers = pluginHandlers desc <> buildHandlers is
47+
}
48+
49+
50+
------------------------------------------------------------------------------
51+
-- | Extract 'PluginHandlers' from 'Interaction's.
52+
buildHandlers
53+
:: [Interaction]
54+
-> PluginHandlers IdeState
55+
buildHandlers cs =
56+
flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) ->
57+
case c_makeCommand c of
58+
SynthesizeCodeAction k ->
59+
mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k
60+
SynthesizeCodeLens k ->
61+
mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k
62+
63+
64+
------------------------------------------------------------------------------
65+
-- | Extract a 'PluginCommand' from an 'Interaction'.
66+
buildCommand
67+
:: PluginId
68+
-> Interaction
69+
-> PluginCommand IdeState
70+
buildCommand plId (Interaction (c :: Continuation sort target b)) =
71+
PluginCommand
72+
{ commandId = toCommandId $ c_sort c
73+
, commandDesc = T.pack ""
74+
, commandFunc = runContinuation plId c
75+
}
76+
77+
78+
------------------------------------------------------------------------------
79+
-- | Boilerplate for running a 'Continuation' as part of an LSP command.
80+
runContinuation
81+
:: forall sort a b
82+
. IsTarget a
83+
=> PluginId
84+
-> Continuation sort a b
85+
-> CommandFunction IdeState (FileContext, b)
86+
runContinuation plId cont state (fc, b) = do
87+
fromMaybeT
88+
(Left $ ResponseError
89+
{ _code = InternalError
90+
, _message = T.pack "TODO(sandy)"
91+
, _xdata = Nothing
92+
} ) $ do
93+
env@LspEnv{..} <- buildEnv state plId fc
94+
let stale a = runStaleIde "runContinuation" state (fc_nfp le_fileContext) a
95+
args <- fetchTargetArgs @a env
96+
c_runCommand cont env args fc b >>= \case
97+
ErrorMessages errs -> do
98+
traverse_ showUserFacingMessage errs
99+
pure $ Right A.Null
100+
RawEdit edits -> do
101+
sendEdits edits
102+
pure $ Right A.Null
103+
GraftEdit gr -> do
104+
ccs <- lift getClientCapabilities
105+
TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
106+
case mkWorkspaceEdits le_dflags ccs (fc_uri le_fileContext) (unTrack pm) gr of
107+
Left errs ->
108+
pure $ Left $ ResponseError
109+
{ _code = InternalError
110+
, _message = T.pack $ show errs
111+
, _xdata = Nothing
112+
}
113+
Right edits -> do
114+
sendEdits edits
115+
pure $ Right A.Null
116+
117+
118+
------------------------------------------------------------------------------
119+
-- | Push a 'WorkspaceEdit' to the client.
120+
sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) ()
121+
sendEdits edits =
122+
void $ lift $
123+
sendRequest
124+
SWorkspaceApplyEdit
125+
(ApplyWorkspaceEditParams Nothing edits)
126+
(const $ pure ())
127+
128+
129+
------------------------------------------------------------------------------
130+
-- | Push a 'UserFacingMessage' to the client.
131+
showUserFacingMessage
132+
:: UserFacingMessage
133+
-> MaybeT (LspM Plugin.Config) ()
134+
showUserFacingMessage ufm =
135+
void $ lift $ showLspMessage $ mkShowMessageParams ufm
136+
137+
138+
------------------------------------------------------------------------------
139+
-- | Build an 'LspEnv', which contains the majority of things we need to know
140+
-- in a 'Continuation'.
141+
buildEnv
142+
:: IdeState
143+
-> PluginId
144+
-> FileContext
145+
-> MaybeT (LspM Plugin.Config) LspEnv
146+
buildEnv state plId fc = do
147+
cfg <- lift $ getTacticConfig plId
148+
dflags <- mapMaybeT liftIO $ getIdeDynflags state $ fc_nfp fc
149+
pure $ LspEnv
150+
{ le_ideState = state
151+
, le_pluginId = plId
152+
, le_dflags = dflags
153+
, le_config = cfg
154+
, le_fileContext = fc
155+
}
156+
157+
158+
------------------------------------------------------------------------------
159+
-- | Lift a 'Continuation' into an LSP CodeAction.
160+
codeActionProvider
161+
:: forall target sort b
162+
. (IsContinuationSort sort, A.ToJSON b, IsTarget target)
163+
=> sort
164+
-> ( LspEnv
165+
-> TargetArgs target
166+
-> MaybeT (LspM Plugin.Config) [(Metadata, b)]
167+
)
168+
-> PluginMethodHandler IdeState TextDocumentCodeAction
169+
codeActionProvider sort k state plId
170+
(CodeActionParams _ _ (TextDocumentIdentifier uri) range _)
171+
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
172+
fromMaybeT (Right $ List []) $ do
173+
let fc = FileContext
174+
{ fc_uri = uri
175+
, fc_nfp = nfp
176+
, fc_range = Just $ unsafeMkCurrent range
177+
}
178+
env <- buildEnv state plId fc
179+
args <- fetchTargetArgs @target env
180+
actions <- k env args
181+
pure
182+
$ Right
183+
$ List
184+
$ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions
185+
codeActionProvider _ _ _ _ _ = pure $ Right $ List []
186+
187+
188+
------------------------------------------------------------------------------
189+
-- | Lift a 'Continuation' into an LSP CodeLens.
190+
codeLensProvider
191+
:: forall target sort b
192+
. (IsContinuationSort sort, A.ToJSON b, IsTarget target)
193+
=> sort
194+
-> ( LspEnv
195+
-> TargetArgs target
196+
-> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]
197+
)
198+
-> PluginMethodHandler IdeState TextDocumentCodeLens
199+
codeLensProvider sort k state plId
200+
(CodeLensParams _ _ (TextDocumentIdentifier uri))
201+
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
202+
fromMaybeT (Right $ List []) $ do
203+
let fc = FileContext
204+
{ fc_uri = uri
205+
, fc_nfp = nfp
206+
, fc_range = Nothing
207+
}
208+
env <- buildEnv state plId fc
209+
args <- fetchTargetArgs @target env
210+
actions <- k env args
211+
pure
212+
$ Right
213+
$ List
214+
$ fmap (uncurry3 $ makeCodeLens plId sort fc) actions
215+
codeLensProvider _ _ _ _ _ = pure $ Right $ List []
216+
217+
218+
------------------------------------------------------------------------------
219+
-- | Build a 'LSP.CodeAction'.
220+
makeCodeAction
221+
:: (A.ToJSON b, IsContinuationSort sort)
222+
=> PluginId
223+
-> FileContext
224+
-> sort
225+
-> Metadata
226+
-> b
227+
-> LSP.CodeAction
228+
makeCodeAction plId fc sort (Metadata title kind preferred) b =
229+
let cmd_id = toCommandId sort
230+
cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)]
231+
in LSP.CodeAction
232+
{ _title = title
233+
, _kind = Just kind
234+
, _diagnostics = Nothing
235+
, _isPreferred = Just preferred
236+
, _disabled = Nothing
237+
, _edit = Nothing
238+
, _command = Just cmd
239+
, _xdata = Nothing
240+
}
241+
242+
243+
------------------------------------------------------------------------------
244+
-- | Build a 'LSP.CodeLens'.
245+
makeCodeLens
246+
:: (A.ToJSON b, IsContinuationSort sort)
247+
=> PluginId
248+
-> sort
249+
-> FileContext
250+
-> Range
251+
-> Metadata
252+
-> b
253+
-> LSP.CodeLens
254+
makeCodeLens plId sort fc range (Metadata title _ _) b =
255+
let fc' = fc { fc_range = Just $ unsafeMkCurrent range }
256+
cmd_id = toCommandId sort
257+
cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)]
258+
in LSP.CodeLens
259+
{ _range = range
260+
, _command = Just cmd
261+
, _xdata = Nothing
262+
}
263+

0 commit comments

Comments
 (0)