Skip to content

Commit 645bb34

Browse files
joyfulmantisjoyfulmantis
authored
Support for resolve for class-plugin lenses (#3769)
1 parent 9cdc7ed commit 645bb34

File tree

6 files changed

+244
-172
lines changed

6 files changed

+244
-172
lines changed

‎plugins/hls-class-plugin/src/Ide/Plugin/Class.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,15 +10,16 @@ import Language.LSP.Protocol.Message
1010
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
1111
descriptor recorder plId = (defaultPluginDescriptor plId)
1212
{ pluginCommands = commands plId
13-
, pluginRules = rules recorder
13+
, pluginRules = getInstanceBindTypeSigsRule recorder >> getInstanceBindLensRule recorder
1414
, pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder)
1515
<> mkPluginHandler SMethod_TextDocumentCodeLens codeLens
16+
<> mkResolveHandler SMethod_CodeLensResolve codeLensResolve
1617
}
1718

1819
commands :: PluginId -> [PluginCommand IdeState]
1920
commands plId
2021
= [ PluginCommand codeActionCommandId
2122
"add placeholders for minimal methods" (addMethodPlaceholders plId)
2223
, PluginCommand typeLensCommandId
23-
"add type signatures for instance methods" codeLensCommandHandler
24+
"add type signatures for instance methods" (codeLensCommandHandler plId)
2425
]

‎plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs

Lines changed: 16 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -106,22 +106,24 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
106106
cls <- findClassFromIdentifier docPath ident
107107
InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state
108108
$ useE GetInstanceBindTypeSigs docPath
109+
(tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath
110+
(hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath
109111
implemented <- findImplementedMethods ast instancePosition
110112
logWith recorder Info (LogImplementedMethods cls implemented)
111113
pure
112114
$ concatMap mkAction
113115
$ nubOrdOn snd
114116
$ filter ((/=) mempty . snd)
115117
$ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))
116-
$ mkMethodGroups range sigs cls
118+
$ mkMethodGroups hsc gblEnv range sigs cls
117119
where
118120
range = diag ^. L.range
119121

120-
mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
121-
mkMethodGroups range sigs cls = minimalDef <> [allClassMethods]
122+
mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
123+
mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods]
122124
where
123-
minimalDef = minDefToMethodGroups range sigs $ classMinimalDef cls
124-
allClassMethods = ("all missing methods", makeMethodDefinitions range sigs)
125+
minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls
126+
allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)
125127

126128
mkAction :: MethodGroup -> [Command |? CodeAction]
127129
mkAction (name, methods)
@@ -211,15 +213,15 @@ type MethodName = T.Text
211213
type MethodDefinition = (MethodName, MethodSignature)
212214
type MethodGroup = (T.Text, [MethodDefinition])
213215

214-
makeMethodDefinition :: InstanceBindTypeSig -> MethodDefinition
215-
makeMethodDefinition sig = (name, signature)
216+
makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition
217+
makeMethodDefinition hsc gblEnv sig = (name, signature)
216218
where
217219
name = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
218-
signature = bindRendered sig
220+
signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig))
219221

220-
makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]
221-
makeMethodDefinitions range sigs =
222-
[ makeMethodDefinition sig
222+
makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
223+
makeMethodDefinitions hsc gblEnv range sigs =
224+
[ makeMethodDefinition hsc gblEnv sig
223225
| sig <- sigs
224226
, inRange range (getSrcSpan $ bindName sig)
225227
]
@@ -228,14 +230,14 @@ signatureToName :: InstanceBindTypeSig -> T.Text
228230
signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
229231

230232
-- Return [groupName text, [(methodName text, signature text)]]
231-
minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
232-
minDefToMethodGroups range sigs minDef = makeMethodGroup <$> go minDef
233+
minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
234+
minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef
233235
where
234236
makeMethodGroup methodDefinitions =
235237
let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions
236238
in (name, methodDefinitions)
237239

238-
go (Var mn) = pure $ makeMethodDefinitions range $ filter ((==) (printOutputable mn) . signatureToName) sigs
240+
go (Var mn) = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs
239241
go (Or ms) = concatMap (go . unLoc) ms
240242
go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms)
241243
go (Parens m) = go (unLoc m)

‎plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs

Lines changed: 67 additions & 111 deletions
Original file line numberDiff line numberDiff line change
@@ -1,20 +1,21 @@
11
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
23
{-# LANGUAGE OverloadedLists #-}
3-
{-# LANGUAGE RecordWildCards #-}
4-
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
5-
4+
{-# LANGUAGE ViewPatterns #-}
65
module Ide.Plugin.Class.CodeLens where
76

8-
import Control.Lens ((^.))
7+
import Control.Lens ((&), (?~), (^.))
98
import Control.Monad.Trans.Class (MonadTrans (lift))
109
import Data.Aeson hiding (Null)
10+
import qualified Data.IntMap.Strict as IntMap
1111
import Data.Maybe (mapMaybe, maybeToList)
1212
import qualified Data.Text as T
1313
import Development.IDE
1414
import Development.IDE.Core.PluginUtils
1515
import Development.IDE.Core.PositionMapping
1616
import Development.IDE.GHC.Compat
17-
import Development.IDE.GHC.Compat.Util
17+
import Development.IDE.Spans.Pragmas (getFirstPragma,
18+
insertNewPragma)
1819
import Ide.Plugin.Class.Types
1920
import Ide.Plugin.Class.Utils
2021
import Ide.Plugin.Error
@@ -25,118 +26,73 @@ import Language.LSP.Protocol.Message
2526
import Language.LSP.Protocol.Types
2627
import Language.LSP.Server (sendRequest)
2728

29+
-- The code lens method is only responsible for providing the ranges of the code
30+
-- lenses matched to a unique id
2831
codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens
29-
codeLens state plId CodeLensParams{..} = do
32+
codeLens state _plId clp = do
33+
nfp <- getNormalizedFilePathE $ clp ^. L.textDocument . L.uri
34+
(InstanceBindLensResult (InstanceBindLens{lensRange}), pm)
35+
<- runActionE "classplugin.GetInstanceBindLens" state
36+
-- Using stale results means that we can almost always return a
37+
-- value. In practice this means the lenses don't 'flicker'
38+
$ useWithStaleE GetInstanceBindLens nfp
39+
pure $ InL $ mapMaybe (toCodeLens pm) lensRange
40+
where toCodeLens pm (range, int) =
41+
let newRange = toCurrentRange pm range
42+
in (\r -> CodeLens r Nothing (Just $ toJSON int)) <$> newRange
43+
44+
-- The code lens resolve method matches a title to each unique id
45+
codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve
46+
codeLensResolve state plId cl uri uniqueID = do
3047
nfp <- getNormalizedFilePathE uri
31-
(tmr, _) <- runActionE "classplugin.TypeCheck" state
32-
-- Using stale results means that we can almost always return a value. In practice
33-
-- this means the lenses don't 'flicker'
34-
$ useWithStaleE TypeCheck nfp
35-
36-
-- All instance binds
37-
(InstanceBindTypeSigsResult allBinds, mp) <- runActionE "classplugin.GetInstanceBindTypeSigs" state
38-
-- Using stale results means that we can almost always return a value. In practice
39-
-- this means the lenses don't 'flicker'
40-
$ useWithStaleE GetInstanceBindTypeSigs nfp
41-
42-
pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs
43-
44-
let (hsGroup, _, _, _) = tmrRenamed tmr
45-
tycls = hs_tyclds hsGroup
46-
-- declared instance methods without signatures
47-
bindInfos = [ bind
48-
| instds <- map group_instds tycls -- class instance decls
49-
, instd <- instds
50-
, inst <- maybeToList $ getClsInstD (unLoc instd)
51-
, bind <- getBindSpanWithoutSig inst
52-
]
53-
targetSigs = matchBind bindInfos allBinds
54-
makeLens (range, title) =
55-
generateLens plId range title
56-
$ workspaceEdit pragmaInsertion
57-
$ makeEdit range title mp
58-
codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs
59-
60-
pure $ InL codeLens
48+
(InstanceBindLensResult (InstanceBindLens{lensDetails}), pm)
49+
<- runActionE "classplugin.GetInstanceBindLens" state
50+
$ useWithStaleE GetInstanceBindLens nfp
51+
(tmrTypechecked -> gblEnv, _) <- runActionE "classplugin.codeAction.TypeCheck" state $ useWithStaleE TypeCheck nfp
52+
(hscEnv -> hsc, _) <- runActionE "classplugin.codeAction.GhcSession" state $ useWithStaleE GhcSession nfp
53+
(range, name, typ) <- handleMaybe PluginStaleResolve
54+
$ IntMap.lookup uniqueID lensDetails
55+
let title = prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc hsc gblEnv typ)
56+
edit <- handleMaybe (PluginInvalidUserState "toCurrentRange") $ makeEdit range title pm
57+
let command = mkLspCommand plId typeLensCommandId title (Just [toJSON $ InstanceBindLensCommand uri edit])
58+
pure $ cl & L.command ?~ command
6159
where
62-
uri = _textDocument ^. L.uri
63-
64-
-- Match Binds with their signatures
65-
-- We try to give every `InstanceBindTypeSig` a `SrcSpan`,
66-
-- hence we can display signatures for `InstanceBindTypeSig` with span later.
67-
matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [InstanceBindTypeSig]
68-
matchBind existedBinds allBindWithSigs =
69-
[foldl go bindSig existedBinds | bindSig <- allBindWithSigs]
70-
where
71-
-- | The `bindDefSpan` of the bind is `Nothing` before,
72-
-- we update it with the span where binding occurs.
73-
-- Hence, we can infer the place to display the signature later.
74-
update :: InstanceBindTypeSig -> SrcSpan -> InstanceBindTypeSig
75-
update bind sp = bind {bindDefSpan = Just sp}
76-
77-
go :: InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig
78-
go bindSig bind = case (srcSpanToRange . bindNameSpan) bind of
79-
Nothing -> bindSig
80-
Just range ->
81-
if inRange range (getSrcSpan $ bindName bindSig)
82-
then update bindSig (bindSpan bind)
83-
else bindSig
84-
85-
getClsInstD (ClsInstD _ d) = Just d
86-
getClsInstD _ = Nothing
87-
88-
getSigName (ClassOpSig _ _ sigNames _) = Just $ map unLoc sigNames
89-
getSigName _ = Nothing
90-
91-
getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo]
92-
getBindSpanWithoutSig ClsInstDecl{..} =
93-
let bindNames = mapMaybe go (bagToList cid_binds)
94-
go (L l bind) = case bind of
95-
FunBind{..}
96-
-- `Generated` tagged for Template Haskell,
97-
-- here we filter out nonsence generated bindings
98-
-- that are nonsense for displaying code lenses.
99-
--
100-
-- See https://github.com/haskell/haskell-language-server/issues/3319
101-
| not $ isGenerated (groupOrigin fun_matches)
102-
-> Just $ L l fun_id
103-
_ -> Nothing
104-
-- Existed signatures' name
105-
sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs
106-
toBindInfo (L l (L l' _)) = BindInfo
107-
(locA l) -- bindSpan
108-
(locA l') -- bindNameSpan
109-
in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames
110-
getBindSpanWithoutSig _ = []
111-
112-
-- Get bind definition range with its rendered signature text
113-
getRangeWithSig :: InstanceBindTypeSig -> Maybe (Range, T.Text)
114-
getRangeWithSig bind = do
115-
span <- bindDefSpan bind
116-
range <- srcSpanToRange span
117-
pure (range, bindRendered bind)
118-
119-
workspaceEdit pragmaInsertion edits =
120-
WorkspaceEdit
121-
(pure [(uri, edits ++ pragmaInsertion)])
122-
Nothing
123-
Nothing
124-
125-
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
126-
generateLens plId range title edit =
127-
let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON edit])
128-
in CodeLens range (Just cmd) Nothing
129-
130-
makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit]
60+
makeEdit :: Range -> T.Text -> PositionMapping -> Maybe TextEdit
13161
makeEdit range bind mp =
13262
let startPos = range ^. L.start
13363
insertChar = startPos ^. L.character
13464
insertRange = Range startPos startPos
13565
in case toCurrentRange mp insertRange of
136-
Just rg -> [TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]
137-
Nothing -> []
66+
Just rg -> Just $ TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")
67+
Nothing -> Nothing
68+
69+
-- Finally the command actually generates and applies the workspace edit for the
70+
-- specified unique id.
71+
codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand
72+
codeLensCommandHandler plId state InstanceBindLensCommand{commandUri, commandEdit} = do
73+
nfp <- getNormalizedFilePathE commandUri
74+
(InstanceBindLensResult (InstanceBindLens{lensEnabledExtensions}), _)
75+
<- runActionE "classplugin.GetInstanceBindLens" state
76+
$ useWithStaleE GetInstanceBindLens nfp
77+
-- We are only interested in the pragma information if the user does not
78+
-- have the InstanceSigs extension enabled
79+
mbPragma <- if InstanceSigs `elem` lensEnabledExtensions
80+
then pure Nothing
81+
else Just <$> getFirstPragma plId state nfp
82+
let -- By mapping over our Maybe NextPragmaInfo value, we only compute this
83+
-- edit if we actually need to.
84+
pragmaInsertion =
85+
maybeToList $ flip insertNewPragma InstanceSigs <$> mbPragma
86+
wEdit = workspaceEdit pragmaInsertion
87+
_ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) (\_ -> pure ())
88+
pure $ InR Null
89+
where
90+
workspaceEdit pragmaInsertion=
91+
WorkspaceEdit
92+
(pure [(commandUri, commandEdit : pragmaInsertion)])
93+
Nothing
94+
Nothing
95+
96+
97+
13898

139-
codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
140-
codeLensCommandHandler _ wedit = do
141-
_ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
142-
pure $ InR Null

0 commit comments

Comments
 (0)