Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit d9aaa01

Browse files
authored
Migrate hls-class-plugin to use StructuredMessage (#4472)
1 parent 93a5f1b commit d9aaa01

File tree

2 files changed

+39
-49
lines changed

2 files changed

+39
-49
lines changed

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

Lines changed: 35 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,15 @@
11
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE OverloadedLists #-}
34
{-# LANGUAGE RecordWildCards #-}
45
{-# LANGUAGE ViewPatterns #-}
56

6-
module Ide.Plugin.Class.CodeAction where
7+
module Ide.Plugin.Class.CodeAction (
8+
addMethodPlaceholders,
9+
codeAction,
10+
) where
711

12+
import Control.Arrow ((>>>))
813
import Control.Lens hiding (List, use)
914
import Control.Monad.Error.Class (MonadError (throwError))
1015
import Control.Monad.Extra
@@ -13,8 +18,6 @@ import Control.Monad.Trans.Class (lift)
1318
import Control.Monad.Trans.Except (ExceptT)
1419
import Control.Monad.Trans.Maybe
1520
import Data.Aeson hiding (Null)
16-
import Data.Bifunctor (second)
17-
import Data.Either.Extra (rights)
1821
import Data.List
1922
import Data.List.Extra (nubOrdOn)
2023
import qualified Data.Map.Strict as Map
@@ -23,11 +26,14 @@ import Data.Maybe (isNothing, listToMaybe,
2326
import qualified Data.Set as Set
2427
import qualified Data.Text as T
2528
import Development.IDE
26-
import Development.IDE.Core.Compile (sourceTypecheck)
2729
import Development.IDE.Core.FileStore (getVersionedTextDoc)
2830
import Development.IDE.Core.PluginUtils
2931
import Development.IDE.Core.PositionMapping (fromCurrentRange)
3032
import Development.IDE.GHC.Compat
33+
import Development.IDE.GHC.Compat.Error (TcRnMessage (..),
34+
_TcRnMessage,
35+
msgEnvelopeErrorL,
36+
stripTcRnMessageContext)
3137
import Development.IDE.GHC.Compat.Util
3238
import Development.IDE.Spans.AtPoint (pointCommand)
3339
import Ide.Plugin.Class.ExactPrint
@@ -80,23 +86,25 @@ addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do
8086
-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
8187
-- sensitive to the format of diagnostic messages from GHC.
8288
codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction
83-
codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
89+
codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do
8490
verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId
8591
nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri)
86-
actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags
87-
pure $ InL actions
92+
activeDiagnosticsInRange (shakeExtras state) nfp caRange
93+
>>= \case
94+
Nothing -> pure $ InL []
95+
Just fileDiags -> do
96+
actions <- join <$> mapM (mkActions nfp verTxtDocId) (methodDiags fileDiags)
97+
pure $ InL actions
8898
where
89-
diags = context ^. L.diagnostics
90-
91-
ghcDiags = filter (\d -> d ^. L.source == Just sourceTypecheck) diags
92-
methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags
99+
methodDiags fileDiags =
100+
mapMaybe (\d -> (d,) <$> isClassMethodWarning (d ^. fdStructuredMessageL)) fileDiags
93101

94102
mkActions
95103
:: NormalizedFilePath
96104
-> VersionedTextDocumentIdentifier
97-
-> Diagnostic
105+
-> (FileDiagnostic, ClassMinimalDef)
98106
-> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction]
99-
mkActions docPath verTxtDocId diag = do
107+
mkActions docPath verTxtDocId (diag, classMinDef) = do
100108
(HAR {hieAst = ast}, pmap) <- runActionE "classplugin.findClassIdentifier.GetHieAst" state
101109
$ useWithStaleE GetHieAst docPath
102110
instancePosition <- handleMaybe (PluginInvalidUserState "fromCurrentRange") $
@@ -108,21 +116,19 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
108116
$ useE GetInstanceBindTypeSigs docPath
109117
(tmrTypechecked -> gblEnv ) <- runActionE "classplugin.codeAction.TypeCheck" state $ useE TypeCheck docPath
110118
(hscEnv -> hsc) <- runActionE "classplugin.codeAction.GhcSession" state $ useE GhcSession docPath
111-
implemented <- findImplementedMethods ast instancePosition
112-
logWith recorder Info (LogImplementedMethods cls implemented)
119+
logWith recorder Debug (LogImplementedMethods (hsc_dflags hsc) cls classMinDef)
113120
pure
114121
$ concatMap mkAction
115122
$ nubOrdOn snd
116123
$ filter ((/=) mempty . snd)
117-
$ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))
118-
$ mkMethodGroups hsc gblEnv range sigs cls
124+
$ mkMethodGroups hsc gblEnv range sigs classMinDef
119125
where
120-
range = diag ^. L.range
126+
range = diag ^. fdLspDiagnosticL .L.range
121127

122-
mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
123-
mkMethodGroups hsc gblEnv range sigs cls = minimalDef <> [allClassMethods]
128+
mkMethodGroups :: HscEnv -> TcGblEnv -> Range -> [InstanceBindTypeSig] -> ClassMinimalDef -> [MethodGroup]
129+
mkMethodGroups hsc gblEnv range sigs classMinDef = minimalDef <> [allClassMethods]
124130
where
125-
minimalDef = minDefToMethodGroups hsc gblEnv range sigs $ classMinimalDef cls
131+
minimalDef = minDefToMethodGroups hsc gblEnv range sigs classMinDef
126132
allClassMethods = ("all missing methods", makeMethodDefinitions hsc gblEnv range sigs)
127133

128134
mkAction :: MethodGroup -> [Command |? CodeAction]
@@ -163,25 +169,6 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
163169
<=< nodeChildren
164170
)
165171

166-
findImplementedMethods
167-
:: HieASTs a
168-
-> Position
169-
-> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [T.Text]
170-
findImplementedMethods asts instancePosition = do
171-
pure
172-
$ concat
173-
$ pointCommand asts instancePosition
174-
$ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers
175-
176-
-- | Recurses through the given AST to find identifiers which are
177-
-- 'InstanceValBind's.
178-
findInstanceValBindIdentifiers :: HieAST a -> [Identifier]
179-
findInstanceValBindIdentifiers ast =
180-
let valBindIds = Map.keys
181-
. Map.filter (any isInstanceValBind . identInfo)
182-
$ getNodeIds ast
183-
in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast)
184-
185172
findClassFromIdentifier docPath (Right name) = do
186173
(hscEnv -> hscenv, _) <- runActionE "classplugin.findClassFromIdentifier.GhcSessionDeps" state
187174
$ useWithStaleE GhcSessionDeps docPath
@@ -203,12 +190,15 @@ isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool
203190
isClassNodeIdentifier (Right i) ident | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident
204191
isClassNodeIdentifier _ _ = False
205192

206-
isClassMethodWarning :: T.Text -> Bool
207-
isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"
193+
isClassMethodWarning :: StructuredMessage -> Maybe ClassMinimalDef
194+
isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage of
195+
Nothing -> Nothing
196+
Just tcRnMessage -> isUnsatisfiedMinimalDefWarning tcRnMessage
208197

209-
isInstanceValBind :: ContextInfo -> Bool
210-
isInstanceValBind (ValBind InstanceBind _ _) = True
211-
isInstanceValBind _ = False
198+
isUnsatisfiedMinimalDefWarning :: TcRnMessage -> Maybe ClassMinimalDef
199+
isUnsatisfiedMinimalDefWarning = stripTcRnMessageContext >>> \case
200+
TcRnUnsatisfiedMinimalDef classMinDef -> Just classMinDef
201+
_ -> Nothing
212202

213203
type MethodSignature = T.Text
214204
type MethodName = T.Text

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -112,15 +112,15 @@ instance NFData InstanceBindLensResult where
112112
type instance RuleResult GetInstanceBindLens = InstanceBindLensResult
113113

114114
data Log
115-
= LogImplementedMethods Class [T.Text]
115+
= LogImplementedMethods DynFlagsClass ClassMinimalDef
116116
| LogShake Shake.Log
117117

118118
instance Pretty Log where
119119
pretty = \case
120-
LogImplementedMethods cls methods ->
121-
pretty ("Detected implemented methods for class" :: String)
120+
LogImplementedMethods dflags cls methods ->
121+
pretty ("The following methods are missing" :: String)
122122
<+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name
123-
<+> pretty methods
123+
<+> pretty (showSDoc dflags $ ppr methods)
124124
LogShake log -> pretty log
125125

126126
data BindInfo = BindInfo

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /