1+ {-# LANGUAGE CPP #-}
12{-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE ViewPatterns #-}
34-- | An HLS plugin to provide code actions to change type signatures
45module 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 )
1829import 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 )
3154import Language.LSP.Protocol.Message
3255import 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
4692getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs ]
4793getDecls (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
97181errorMessageRegexes :: [Text ]
98182errorMessageRegexes = [ -- 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
147228changeSigToCodeAction (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