Skip to content

Commit 6845e57

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

File tree

2 files changed

+73
-26
lines changed

2 files changed

+73
-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: 71 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,16 @@ module Ide.Plugin.ChangeTypeSignature (descriptor
66
, errorMessageRegexes
77
) where
88

9-
import Control.Monad (guard)
9+
import Control.Lens
10+
import Control.Monad (guard, forM)
1011
import Control.Monad.IO.Class (MonadIO)
1112
import Control.Monad.Trans.Except (ExceptT)
1213
import Data.Foldable (asum)
1314
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))
2021
import Development.IDE.Core.Service (IdeState)
@@ -31,17 +32,26 @@ import Ide.Types (PluginDescriptor (..),
3132
import Language.LSP.Protocol.Message
3233
import Language.LSP.Protocol.Types
3334
import Text.Regex.TDFA ((=~))
35+
import Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
36+
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage)
37+
import GHC.Tc.Errors.Types (TcSolverReportMsg(..), TcRnMessage (..), TcRnMessage (..), SolverReportWithCtxt (..), TcRnMessageDetailed (..), MismatchMsg (..), ErrInfo (..))
38+
import GHC.IO (unsafePerformIO)
3439

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

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

4656
getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
4757
getDecls (PluginId changeTypeSignatureId) state =
@@ -67,39 +77,74 @@ data ChangeSignature = ChangeSignature {
6777
-- | the location of the declaration signature
6878
, declSrcSpan :: RealSrcSpan
6979
-- | the diagnostic to solve
70-
, diagnostic :: Diagnostic
80+
, diagnostic :: FileDiagnostic
7181
}
7282

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

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

86104

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

96143
-- | List of regexes that match various Error Messages
97144
errorMessageRegexes :: [Text]
98145
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 ‘(.+)’"
146+
"In an equation for ‘(.+)’:" -- TODO: Check if this is useful only for tests
147+
, "In an equation for `(.+)':"
103148
]
104149

105150
-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches
@@ -147,7 +192,7 @@ changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAc
147192
changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} =
148193
InR CodeAction { _title = mkChangeSigTitle declName actualType
149194
, _kind = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId))
150-
, _diagnostics = Just [diagnostic]
195+
, _diagnostics = Just [diagnostic ^. fdLspDiagnosticL ]
151196
, _isPreferred = Nothing
152197
, _disabled = Nothing
153198
, _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType)

0 commit comments

Comments
 (0)