Skip to content

Commit d90e73e

Browse files
sgillespiesgillespie
committed
Migrate change-type-signature-plugin to use structured diagnostics
1 parent 0a26bd5 commit d90e73e

File tree

2 files changed

+71
-26
lines changed

2 files changed

+71
-26
lines changed

‎haskell-language-server.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1168,12 +1168,14 @@ library hls-change-type-signature-plugin
11681168
build-depends:
11691169
, ghcide == 2.11.0.0
11701170
, hls-plugin-api == 2.11.0.0
1171+
, lens
11711172
, lsp-types
11721173
, regex-tdfa
11731174
, syb
11741175
, text
11751176
, transformers
11761177
, containers
1178+
, ghc
11771179
default-extensions:
11781180
DataKinds
11791181
ExplicitNamespaces

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

Lines changed: 69 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Ide.Plugin.ChangeTypeSignature (descriptor
66
, errorMessageRegexes
77
) where
88

9+
import Control.Lens
910
import Control.Monad (guard)
1011
import Control.Monad.IO.Class (MonadIO)
1112
import Control.Monad.Trans.Except (ExceptT)
@@ -14,10 +15,9 @@ import qualified Data.Map as Map
1415
import Data.Maybe (mapMaybe)
1516
import Data.Text (Text)
1617
import qualified Data.Text as T
17-
import Development.IDE (realSrcSpanToRange)
18+
import Development.IDE (realSrcSpanToRange, IdeState (..), FileDiagnostic, fdLspDiagnosticL, fdStructuredMessageL)
1819
import Development.IDE.Core.PluginUtils
1920
import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule))
20-
import Development.IDE.Core.Service (IdeState)
2121
import Development.IDE.GHC.Compat
2222
import Development.IDE.GHC.Util (printOutputable)
2323
import Generics.SYB (extQ, something)
@@ -31,17 +31,25 @@ import Ide.Types (PluginDescriptor (..),
3131
import Language.LSP.Protocol.Message
3232
import Language.LSP.Protocol.Types
3333
import Text.Regex.TDFA ((=~))
34+
import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
35+
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage)
36+
import GHC.Tc.Errors.Types (TcSolverReportMsg(..), TcRnMessage (..), TcRnMessage (..), SolverReportWithCtxt (..), TcRnMessageDetailed (..), MismatchMsg (..), ErrInfo (..))
3437

3538
descriptor :: PluginId -> PluginDescriptor IdeState
3639
descriptor plId = (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
3740
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) }
3841

3942
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
43+
codeActionHandler plId ideState _ CodeActionParams{_textDocument, _range} = do
44+
let TextDocumentIdentifier uri = _textDocument
45+
nfp <- getNormalizedFilePathE uri
46+
decls <- getDecls plId ideState nfp
47+
48+
activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case
49+
Nothing -> pure (InL [])
50+
Just fileDiags -> do
51+
let actions = mapMaybe (generateAction plId uri decls) fileDiags
52+
pure (InL actions)
4553

4654
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
4755
getDecls (PluginId changeTypeSignatureId) state =
@@ -67,39 +75,74 @@ data ChangeSignature = ChangeSignature {
6775
-- | the location of the declaration signature
6876
, declSrcSpan :: RealSrcSpan
6977
-- | the diagnostic to solve
70-
, diagnostic :: Diagnostic
78+
, diagnostic :: FileDiagnostic
7179
}
7280

7381
-- | 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
82+
generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> FileDiagnostic -> Maybe (Command |? CodeAction)
83+
generateAction plId uri decls fileDiag =
84+
changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls fileDiag
7685

7786
-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan
78-
diagnosticToChangeSig :: [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
87+
diagnosticToChangeSig :: [LHsDecl GhcPs] -> FileDiagnostic -> Maybe ChangeSignature
7988
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
89+
msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage
90+
tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessage
91+
(solverReport, errInfo) <- findSolverReport tcRnMsg
92+
mismatch <- findMismatchMessage solverReport
93+
(expectedType', actualType') <- findTypeEqMismatch mismatch
94+
errInfo' <- errInfo
95+
96+
let expectedType = showType expectedType'
97+
actualType = showType actualType'
98+
99+
declName <- matchingDiagnostic errInfo'
83100
declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName)
84-
pure $ ChangeSignature{..}
85101

86102

103+
Just (ChangeSignature{..})
104+
where
105+
showType :: Type -> Text
106+
showType = T.pack . showSDocUnsafe . pprTidiedType
107+
108+
-- TODO: Make this a prism?
109+
findSolverReport :: TcRnMessage -> Maybe (TcSolverReportMsg, Maybe ErrInfo)
110+
findSolverReport (TcRnMessageWithInfo _ (TcRnMessageDetailed errInfo msg)) =
111+
case findSolverReport msg of
112+
Just (mismatch, _) -> Just (mismatch, Just errInfo)
113+
_ -> Nothing
114+
findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _ _) =
115+
Just (mismatch, Nothing)
116+
findSolverReport _ = Nothing
117+
118+
-- TODO: Make this a prism?
119+
findMismatchMessage :: TcSolverReportMsg -> Maybe MismatchMsg
120+
findMismatchMessage (Mismatch m _ _ _) = Just m
121+
findMismatchMessage _ = Nothing
122+
123+
-- TODO: Make this a prism?
124+
findTypeEqMismatch :: MismatchMsg -> Maybe (Type, Type)
125+
findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) =
126+
Just (expected, actual)
127+
findTypeEqMismatch _ = Nothing
128+
87129
-- | 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
130+
matchingDiagnostic :: ErrInfo -> Maybe DeclName
131+
matchingDiagnostic ErrInfo{errInfoContext} =
132+
asum $ map (unwrapMatch . (=~) errInfoTxt) errorMessageRegexes
90133
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
134+
unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe DeclName
135+
unwrapMatch (_, _, _, [name]) = Just name
136+
unwrapMatch _ = Nothing
137+
138+
-- TODO: Unsafe?
139+
errInfoTxt = T.pack $ showSDocUnsafe errInfoContext
95140

96141
-- | List of regexes that match various Error Messages
97142
errorMessageRegexes :: [Text]
98143
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 ‘(.+)’"
144+
"In an equation for ‘(.+)’:" -- TODO: Check if this is useful only for tests
145+
, "In an equation for `(.+)':"
103146
]
104147

105148
-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches
@@ -147,7 +190,7 @@ changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAc
147190
changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} =
148191
InR CodeAction { _title = mkChangeSigTitle declName actualType
149192
, _kind = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId))
150-
, _diagnostics = Just [diagnostic]
193+
, _diagnostics = Just [diagnostic ^. fdLspDiagnosticL ]
151194
, _isPreferred = Nothing
152195
, _disabled = Nothing
153196
, _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType)

0 commit comments

Comments
 (0)