Skip to content

Commit 6f05c56

Browse files
crtschincrtschin
committed
Consume Name-keyed class rule in CodeAction
1 parent a809980 commit 6f05c56

2 files changed

Lines changed: 43 additions & 92 deletions

File tree

‎haskell-language-server.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -358,7 +358,6 @@ library hls-class-plugin
358358
, hls-plugin-api == 2.14.0.0
359359
, lens
360360
, lsp
361-
, mtl
362361
, text
363362
, transformers
364363

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

Lines changed: 43 additions & 91 deletions
Original file line numberDiff line numberDiff line change
@@ -10,44 +10,36 @@ module Ide.Plugin.Class.CodeAction (
1010
codeAction,
1111
) where
1212

13-
import Control.Arrow ((>>>))
14-
import Control.Lens hiding (List, use)
15-
import Control.Monad.Error.Class (MonadError (throwError))
13+
import Control.Arrow ((>>>))
14+
import Control.Lens hiding (List, use)
1615
import Control.Monad.Extra
17-
import Control.Monad.IO.Class (liftIO)
18-
import Control.Monad.Trans.Class (lift)
19-
import Control.Monad.Trans.Except (ExceptT)
16+
import Control.Monad.IO.Class (liftIO)
17+
import Control.Monad.Trans.Class (lift)
18+
import Control.Monad.Trans.Except (ExceptT)
2019
import Control.Monad.Trans.Maybe
21-
import Data.Aeson hiding (Null)
20+
import Data.Aeson hiding (Null)
2221
import Data.List
23-
import Data.List.Extra (nubOrdOn)
24-
import qualified Data.Map.Strict as Map
25-
import Data.Maybe (isNothing, listToMaybe,
26-
mapMaybe)
27-
import qualified Data.Set as Set
28-
import qualified Data.Text as T
22+
import Data.List.Extra (nubOrdOn)
23+
import Data.Maybe (listToMaybe, mapMaybe)
24+
import qualified Data.Text as T
2925
import Development.IDE
30-
import Development.IDE.Core.FileStore (getVersionedTextDoc)
26+
import Development.IDE.Core.FileStore (getVersionedTextDoc)
3127
import Development.IDE.Core.PluginUtils
32-
import Development.IDE.Core.PositionMapping (fromCurrentRange)
3328
import Development.IDE.GHC.Compat
34-
import Development.IDE.GHC.Compat.Error (TcRnMessage (..),
35-
_TcRnMessage,
36-
msgEnvelopeErrorL,
37-
stripTcRnMessageContext)
29+
import Development.IDE.GHC.Compat.Error (TcRnMessage (..),
30+
_TcRnMessage,
31+
msgEnvelopeErrorL,
32+
stripTcRnMessageContext)
3833
import Development.IDE.GHC.Compat.Util
39-
import Development.IDE.Spans.AtPoint (pointCommand)
40-
import GHC.Iface.Ext.Types (ContextInfo (..),
41-
HieAST (..), Identifier,
42-
IdentifierDetails (..))
4334
import Ide.Plugin.Class.ExactPrint
4435
import Ide.Plugin.Class.Types
4536
import Ide.Plugin.Class.Utils
4637
import qualified Ide.Plugin.Config
4738
import Ide.Plugin.Error
39+
import qualified Ide.Plugin.RangeMap as RangeMap
4840
import Ide.PluginUtils
4941
import Ide.Types
50-
import qualified Language.LSP.Protocol.Lens as L
42+
import qualified Language.LSP.Protocol.Lens as L
5143
import Language.LSP.Protocol.Message
5244
import Language.LSP.Protocol.Types
5345

@@ -109,31 +101,28 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do
109101
-> (FileDiagnostic, ClassMinimalDef)
110102
-> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction]
111103
mkActions docPath verTxtDocId (diag, classMinDef) = do
112-
(HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state
113-
$ useWithStaleE GetHieAst docPath
114-
instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $
115-
fromCurrentRange pmap range ^? _Just . L.start
116-
& fmap (L.character -~ 1)
117-
ident <- findClassIdentifier ast instancePosition
118-
cls <- findClassFromIdentifier docPath ident
119-
InstanceBindTypeSigsResult sigs <- runActionE "classplugin.codeAction.GetInstanceBindTypeSigs" state
120-
$ useE GetInstanceBindTypeSigs docPath
121-
(tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath
104+
ClassInstancesResult instMap <- runActionE "classplugin.codeAction.GetClassInstances" state
105+
$ useE GetClassInstances docPath
106+
inst <- handleMaybe (PluginInvalidUserState "no instance at diagnostic range")
107+
$ listToMaybe (RangeMap.filterByRange range instMap)
108+
(tmrTypechecked -> gblEnv) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath
122109
(hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath
123-
logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) cls classMinDef)
110+
logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) (instClass inst) classMinDef)
124111
pure
125112
$ concatMap mkAction
126113
$ nubOrdOn snd
127114
$ filter ((/=) mempty . snd)
128-
$ mkMethodGroups hsc gblEnv range sigs classMinDef
115+
$ mkMethodGroups hsc gblEnv inst classMinDef
129116
where
130117
range = diag ^. fdLspDiagnosticL . L.range
131118

132-
mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]
133-
mkMethodGroups hsc gblEnv range sigs classMinDef = minimalDef <> [allClassMethods]
119+
mkMethodGroups :: HscEnv -> TcGblEnv -> InstanceInfo -> ClassMinimalDef -> [MethodGroup]
120+
mkMethodGroups hsc gblEnv inst classMinDef = minimalDef <> [allClassMethods]
134121
where
135-
minimalDef = minDefToMethodGroups hsc gblEnv range sigs classMinDef
136-
allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)
122+
methods = instMethods inst
123+
minimalDef = minDefToMethodGroups hsc gblEnv methods classMinDef
124+
allClassMethods =
125+
("all missing methods", map (makeMethodDefinition hsc gblEnv) methods)
137126

138127
mkAction :: MethodGroup -> [Command |? CodeAction]
139128
mkAction (name, methods)
@@ -164,36 +153,6 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do
164153
(Just cmd)
165154
Nothing
166155

167-
findClassIdentifier hf instancePosition =
168-
handleMaybe (PluginInternalError "No Identifier found")
169-
$ listToMaybe
170-
$ mapMaybe listToMaybe
171-
$ pointCommand hf instancePosition
172-
( (Map.keys . Map.filterWithKey isClassNodeIdentifier . getNodeIds)
173-
<=< nodeChildren
174-
)
175-
176-
findClassFromIdentifier docPath (Right name) = do
177-
(hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state
178-
$ useWithStaleE GhcSessionDeps docPath
179-
(tmrTypechecked -> thisMod, _) <- runActionE "classplugin.findClassFromIdentifier.TypeCheck" state
180-
$ useWithStaleE TypeCheck docPath
181-
handleMaybeM (PluginInternalError "initTcWithGbl failed")
182-
. liftIO
183-
. fmap snd
184-
. initTcWithGbl hscenv thisMod ghostSpan $ do
185-
tcthing <- tcLookup name
186-
case tcthing of
187-
AGlobal (AConLike (RealDataCon con))
188-
| Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls
189-
_ -> fail "Ide.Plugin.Class.findClassFromIdentifier"
190-
findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier")
191-
192-
-- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc
193-
isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool
194-
isClassNodeIdentifier (Right i) ident | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident
195-
isClassNodeIdentifier _ _ = False
196-
197156
isClassMethodWarning :: StructuredMessage -> Maybe ClassMinimalDef
198157
isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
199158
Nothing -> Nothing
@@ -209,36 +168,29 @@ type MethodName = T.Text
209168
type MethodDefinition = (MethodName, MethodSignature)
210169
type MethodGroup = (T.Text, [MethodDefinition])
211170

212-
makeMethodDefinition :: HscEnv -> TcGblEnv -> InstanceBindTypeSig -> MethodDefinition
213-
makeMethodDefinition hsc gblEnv sig = (name, signature)
171+
makeMethodDefinition :: HscEnv -> TcGblEnv -> (Name, Type) -> MethodDefinition
172+
makeMethodDefinition hsc gblEnv (name, ty) = (nameTxt, signature)
214173
where
215-
name = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
216-
signature = prettyBindingNameString (printOutputable (bindName sig)) <> " :: " <> T.pack (showDoc hsc gblEnv (bindType sig))
217-
218-
makeMethodDefinitions :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> [MethodDefinition]
219-
makeMethodDefinitions hsc gblEnv range sigs =
220-
[ makeMethodDefinition hsc gblEnv sig
221-
| sig <- sigs
222-
, inRange range (getSrcSpan $ bindName sig)
223-
]
224-
225-
signatureToName :: InstanceBindTypeSig -> T.Text
226-
signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
227-
228-
-- Return [groupName text, [(methodName text, signature text)]]
229-
minDefToMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]
230-
minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDef
174+
-- nameTxt is bare (no parens); ExactPrint.makeMethodDecl applies
175+
-- toMethodName to wrap operators when emitting the placeholder.
176+
nameTxt = printOutputable name
177+
signature = toMethodName nameTxt <> " :: " <> T.pack (showDoc hsc gblEnv ty)
178+
179+
minDefToMethodGroups :: HscEnv -> TcGblEnv -> [(Name, Type)] -> ClassMinimalDef -> [MethodGroup]
180+
minDefToMethodGroups hsc gblEnv methods minDef = makeMethodGroup <$> go minDef
231181
where
232182
makeMethodGroup methodDefinitions =
233183
let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions
234184
in (name, methodDefinitions)
235185

186+
matchMethod n =
187+
map (makeMethodDefinition hsc gblEnv)
188+
$ filter ((== printOutputable n) . printOutputable . fst) methods
236189
#if __GLASGOW_HASKELL__ >= 913
237-
go (Var lmn) = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable (unLoc lmn)) . signatureToName) sigs
190+
go (Var lmn) = pure $ matchMethod (unLoc lmn)
238191
#else
239-
go (Var mn) = pure $ makeMethodDefinitions hsc gblEnv range $ filter ((==) (printOutputable mn) . signatureToName) sigs
192+
go (Var mn) = pure $ matchMethod mn
240193
#endif
241194
go (Or ms) = concatMap (go . unLoc) ms
242195
go (And ms) = foldr (liftA2 (<>) . go . unLoc) [[]] ms
243196
go (Parens m) = go (unLoc m)
244-

0 commit comments

Comments
 (0)