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 8d96270

Browse files
Migrate change-type-signature-plugin to use structured diagnostics (#4632)
* Migrate change-type-signature-plugin to use structured diagnostics * Refactor: Turn some getter functions into Lenses/Treversals * fix: Use updated traversal for error messages _TcRnMessage -> _TcRnMessageWithCtx * Refactor: Extract additional Prisms/Lenses into a common module
1 parent 0a9b1cb commit 8d96270

File tree

16 files changed

+240
-155
lines changed

16 files changed

+240
-155
lines changed

‎ghcide/src/Development/IDE/GHC/Compat/Error.hs

Lines changed: 42 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,16 +17,24 @@ module Development.IDE.GHC.Compat.Error (
1717
DriverMessage (..),
1818
-- * General Diagnostics
1919
Diagnostic(..),
20-
-- * Prisms for error selection
20+
-- * Prisms and lenses for error selection
2121
_TcRnMessage,
2222
_TcRnMessageWithCtx,
2323
_GhcPsMessage,
2424
_GhcDsMessage,
2525
_GhcDriverMessage,
2626
_TcRnMissingSignature,
27+
_TcRnSolverReport,
28+
_TcRnMessageWithInfo,
29+
reportContextL,
30+
reportContentL,
31+
_MismatchMessage,
32+
_TypeEqMismatchActual,
33+
_TypeEqMismatchExpected,
2734
) where
2835

2936
import Control.Lens
37+
import Development.IDE.GHC.Compat (Type)
3038
import GHC.Driver.Errors.Types
3139
import GHC.HsToCore.Errors.Types
3240
import GHC.Tc.Errors.Types
@@ -82,3 +90,36 @@ msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
8290
msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )
8391

8492
makePrisms ''TcRnMessage
93+
94+
makeLensesWith
95+
(lensRules & lensField .~ mappingNamer (pure . (++ "L")))
96+
''SolverReportWithCtxt
97+
98+
-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be
99+
-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors.
100+
_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
101+
_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg
102+
_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg
103+
_MismatchMessage _ report = pure report
104+
105+
-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'.
106+
_TypeEqMismatchExpected :: Traversal' MismatchMsg Type
107+
#if MIN_VERSION_ghc(9,12,0)
108+
_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =
109+
(\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
110+
#else
111+
_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) =
112+
(\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
113+
#endif
114+
_TypeEqMismatchExpected _ mismatch = pure mismatch
115+
116+
-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'.
117+
_TypeEqMismatchActual :: Traversal' MismatchMsg Type
118+
#if MIN_VERSION_ghc(9,12,0)
119+
_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =
120+
(\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual
121+
#else
122+
_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) =
123+
(\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual
124+
#endif
125+
_TypeEqMismatchActual _ mismatch = pure mismatch

‎haskell-language-server.cabal

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1173,12 +1173,14 @@ library hls-change-type-signature-plugin
11731173
build-depends:
11741174
, ghcide == 2.11.0.0
11751175
, hls-plugin-api == 2.11.0.0
1176+
, lens
11761177
, lsp-types
11771178
, regex-tdfa
11781179
, syb
11791180
, text
11801181
, transformers
11811182
, containers
1183+
, ghc
11821184
default-extensions:
11831185
DataKinds
11841186
ExplicitNamespaces
@@ -1196,6 +1198,7 @@ test-suite hls-change-type-signature-plugin-tests
11961198
build-depends:
11971199
, filepath
11981200
, haskell-language-server:hls-change-type-signature-plugin
1201+
, hls-plugin-api
11991202
, hls-test-utils == 2.11.0.0
12001203
, regex-tdfa
12011204
, text

‎plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs

Lines changed: 136 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -1,47 +1,93 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE ViewPatterns #-}
34
-- | An HLS plugin to provide code actions to change type signatures
45
module Ide.Plugin.ChangeTypeSignature (descriptor
56
-- * For Unit Tests
7+
, Log(..)
68
, errorMessageRegexes
79
) where
810

9-
import Control.Monad (guard)
10-
import Control.Monad.IO.Class (MonadIO)
11-
import Control.Monad.Trans.Except (ExceptT)
12-
import Data.Foldable (asum)
13-
import qualified Data.Map as Map
14-
import Data.Maybe (mapMaybe)
15-
import Data.Text (Text)
16-
import qualified Data.Text as T
17-
import Development.IDE (realSrcSpanToRange)
11+
import Control.Lens
12+
import Control.Monad (guard)
13+
import Control.Monad.IO.Class (MonadIO)
14+
import Control.Monad.Trans.Class (MonadTrans (lift))
15+
import Control.Monad.Trans.Except (ExceptT (..))
16+
import Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe)
17+
import Data.Foldable (asum)
18+
import qualified Data.Map as Map
19+
import Data.Maybe (catMaybes)
20+
import Data.Text (Text)
21+
import qualified Data.Text as T
22+
import Development.IDE (FileDiagnostic,
23+
IdeState (..), Pretty (..),
24+
Priority (..), Recorder,
25+
WithPriority,
26+
fdLspDiagnosticL,
27+
fdStructuredMessageL,
28+
logWith, realSrcSpanToRange)
1829
import Development.IDE.Core.PluginUtils
19-
import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
20-
import Development.IDE.Core.Service (IdeState)
21-
import Development.IDE.GHC.Compat
22-
import Development.IDE.GHC.Util (printOutputable)
23-
import Generics.SYB (extQ, something)
24-
import Ide.Plugin.Error (PluginError,
25-
getNormalizedFilePathE)
26-
import Ide.Types (PluginDescriptor (..),
27-
PluginId (PluginId),
28-
PluginMethodHandler,
29-
defaultPluginDescriptor,
30-
mkPluginHandler)
30+
import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
31+
import Development.IDE.GHC.Compat hiding (vcat)
32+
import Development.IDE.GHC.Compat.Error (_MismatchMessage,
33+
_TcRnMessageWithCtx,
34+
_TcRnMessageWithInfo,
35+
_TcRnSolverReport,
36+
_TypeEqMismatchActual,
37+
_TypeEqMismatchExpected,
38+
msgEnvelopeErrorL,
39+
reportContentL)
40+
import Development.IDE.GHC.Util (printOutputable)
41+
import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
42+
import Generics.SYB (extQ, something)
43+
import GHC.Tc.Errors.Types (ErrInfo (..),
44+
TcRnMessageDetailed (..))
45+
import qualified Ide.Logger as Logger
46+
import Ide.Plugin.Error (PluginError,
47+
getNormalizedFilePathE)
48+
import Ide.Types (Config, HandlerM,
49+
PluginDescriptor (..),
50+
PluginId (PluginId),
51+
PluginMethodHandler,
52+
defaultPluginDescriptor,
53+
mkPluginHandler)
3154
import Language.LSP.Protocol.Message
3255
import Language.LSP.Protocol.Types
33-
import Text.Regex.TDFA ((=~))
34-
35-
descriptor :: PluginId -> PluginDescriptor IdeState
36-
descriptor plId = (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
37-
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) }
38-
39-
codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
40-
codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = do
41-
nfp <- getNormalizedFilePathE uri
42-
decls <- getDecls plId ideState nfp
43-
let actions = mapMaybe (generateAction plId uri decls) diags
44-
pure $ InL actions
56+
import Text.Regex.TDFA ((=~))
57+
58+
data Log
59+
= LogErrInfoCtxt ErrInfo
60+
| LogFindSigLocFailure DeclName
61+
62+
instance Pretty Log where
63+
pretty = \case
64+
LogErrInfoCtxt (ErrInfo ctxt suppl) ->
65+
Logger.vcat [fromSDoc ctxt, fromSDoc suppl]
66+
LogFindSigLocFailure name ->
67+
pretty ("Lookup signature location failure: " <> name)
68+
where
69+
fromSDoc = pretty . printOutputable
70+
71+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
72+
descriptor recorder plId =
73+
(defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
74+
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler recorder plId)
75+
}
76+
77+
codeActionHandler
78+
:: Recorder (WithPriority Log)
79+
-> PluginId
80+
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
81+
codeActionHandler recorder plId ideState _ CodeActionParams{_textDocument, _range} = do
82+
let TextDocumentIdentifier uri = _textDocument
83+
nfp <- getNormalizedFilePathE uri
84+
decls <- getDecls plId ideState nfp
85+
86+
activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case
87+
Nothing -> pure (InL [])
88+
Just fileDiags -> do
89+
actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags
90+
pure (InL (catMaybes actions))
4591

4692
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
4793
getDecls (PluginId changeTypeSignatureId) state =
@@ -67,39 +113,74 @@ data ChangeSignature = ChangeSignature {
67113
-- | the location of the declaration signature
68114
, declSrcSpan :: RealSrcSpan
69115
-- | the diagnostic to solve
70-
, diagnostic :: Diagnostic
116+
, diagnostic :: FileDiagnostic
71117
}
72118

73119
-- | Create a CodeAction from a Diagnostic
74-
generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)
75-
generateAction plId uri decls diag = changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls diag
120+
generateAction
121+
:: Recorder (WithPriority Log)
122+
-> PluginId
123+
-> Uri
124+
-> [LHsDecl GhcPs]
125+
-> FileDiagnostic
126+
-> HandlerM Config (Maybe (Command |? CodeAction))
127+
generateAction recorder plId uri decls fileDiag = do
128+
changeSig <- diagnosticToChangeSig recorder decls fileDiag
129+
pure $
130+
changeSigToCodeAction plId uri <$> changeSig
76131

77132
-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan
78-
diagnosticToChangeSig :: [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
79-
diagnosticToChangeSig decls diagnostic = do
80-
-- regex match on the GHC Error Message
81-
(expectedType, actualType, declName) <- matchingDiagnostic diagnostic
82-
-- Find the definition and it's location
83-
declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName)
84-
pure $ ChangeSignature{..}
85-
133+
diagnosticToChangeSig
134+
:: Recorder (WithPriority Log)
135+
-> [LHsDecl GhcPs]
136+
-> FileDiagnostic
137+
-> HandlerM Config (Maybe ChangeSignature)
138+
diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do
139+
-- Extract expected, actual, and extra error info
140+
(expectedType, actualType, errInfo) <- hoistMaybe $ do
141+
msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage
142+
tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessageWithCtx
143+
(_, TcRnMessageDetailed errInfo tcRnMsg') <- tcRnMsg ^? _TcRnMessageWithInfo
144+
solverReport <- tcRnMsg' ^? _TcRnSolverReport . _1 . reportContentL
145+
mismatch <- solverReport ^? _MismatchMessage
146+
expectedType <- mismatch ^? _TypeEqMismatchExpected
147+
actualType <- mismatch ^? _TypeEqMismatchActual
148+
149+
pure (showType expectedType, showType actualType, errInfo)
150+
151+
logWith recorder Debug (LogErrInfoCtxt errInfo)
152+
153+
-- Extract the declName from the extra error text
154+
declName <- hoistMaybe (matchingDiagnostic errInfo)
155+
156+
-- Look up location of declName. If it fails, log it
157+
declSrcSpan <-
158+
case findSigLocOfStringDecl decls expectedType (T.unpack declName) of
159+
Just x -> pure x
160+
Nothing -> do
161+
logWith recorder Debug (LogFindSigLocFailure declName)
162+
hoistMaybe Nothing
163+
164+
pure ChangeSignature{..}
165+
where
166+
showType :: Type -> Text
167+
showType = T.pack . showSDocUnsafe . pprTidiedType
86168

87169
-- | If a diagnostic has the proper message create a ChangeSignature from it
88-
matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName)
89-
matchingDiagnostic Diagnostic{_message} = asum $ map (unwrapMatch . (=~) _message) errorMessageRegexes
170+
matchingDiagnostic :: ErrInfo -> Maybe DeclName
171+
matchingDiagnostic ErrInfo{errInfoContext} =
172+
asum $ map (unwrapMatch . (=~) errInfoTxt) errorMessageRegexes
90173
where
91-
unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName)
92-
-- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match
93-
unwrapMatch (_, _, _, [expect, actual, _, name]) = Just (expect, actual, name)
94-
unwrapMatch _ = Nothing
174+
unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe DeclName
175+
unwrapMatch (_, _, _, [name]) = Just name
176+
unwrapMatch _ = Nothing
177+
178+
errInfoTxt = printOutputable errInfoContext
95179

96180
-- | List of regexes that match various Error Messages
97181
errorMessageRegexes :: [Text]
98182
errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests
99-
"Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’"
100-
, "Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’"
101-
-- GHC >9.2 version of the first error regex
102-
, "Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’"
183+
"In an equation for ‘(.+)’:"
103184
]
104185

105186
-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches
@@ -147,7 +228,7 @@ changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAc
147228
changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} =
148229
InR CodeAction { _title = mkChangeSigTitle declName actualType
149230
, _kind = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId))
150-
, _diagnostics = Just [diagnostic]
231+
, _diagnostics = Just [diagnostic^. fdLspDiagnosticL ]
151232
, _isPreferred = Nothing
152233
, _disabled = Nothing
153234
, _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType)

0 commit comments

Comments
(0)

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