Migrate change-type-signature-plugin to use structured diagnostics

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

@@ -17,16 +17,24 @@ module Development.IDE.GHC.Compat.Error (
   DriverMessage (..),
   -- * General Diagnostics
   Diagnostic(..),
-  -- * Prisms for error selection
+  -- * Prisms and lenses for error selection
   _TcRnMessage,
   _TcRnMessageWithCtx,
   _GhcPsMessage,
   _GhcDsMessage,
   _GhcDriverMessage,
   _TcRnMissingSignature,
+  _TcRnSolverReport,
+  _TcRnMessageWithInfo,
+  reportContextL,
+  reportContentL,
+  _MismatchMessage,
+  _TypeEqMismatchActual,
+  _TypeEqMismatchExpected,
   ) where
 
 import           Control.Lens
+import           Development.IDE.GHC.Compat (Type)
 import           GHC.Driver.Errors.Types
 import           GHC.HsToCore.Errors.Types
 import           GHC.Tc.Errors.Types
@@ -82,3 +90,36 @@ msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
 msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )
 
 makePrisms ''TcRnMessage
+
+makeLensesWith
+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
+    ''SolverReportWithCtxt
+
+-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be
+-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors.
+_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
+_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg
+_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg
+_MismatchMessage _ report = pure report
+
+-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'.
+_TypeEqMismatchExpected :: Traversal' MismatchMsg Type
+#if MIN_VERSION_ghc(9,12,0)
+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =
+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
+#else
+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) =
+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
+#endif
+_TypeEqMismatchExpected _ mismatch = pure mismatch
+
+-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'.
+_TypeEqMismatchActual :: Traversal' MismatchMsg Type
+#if MIN_VERSION_ghc(9,12,0)
+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =
+    (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual
+#else
+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) =
+    (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual
+#endif
+_TypeEqMismatchActual _ mismatch = pure mismatch

haskell-language-server.cabal

@@ -1173,12 +1173,14 @@ library hls-change-type-signature-plugin
   build-depends:
     , ghcide           == 2.11.0.0
     , hls-plugin-api   == 2.11.0.0
+    , lens
     , lsp-types
     , regex-tdfa
     , syb
     , text
     , transformers
     , containers
+    , ghc
   default-extensions:
     DataKinds
     ExplicitNamespaces
@@ -1196,6 +1198,7 @@ test-suite hls-change-type-signature-plugin-tests
   build-depends:
     , filepath
     , haskell-language-server:hls-change-type-signature-plugin
+    , hls-plugin-api
     , hls-test-utils       == 2.11.0.0
     , regex-tdfa
     , text

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

@@ -1,47 +1,93 @@
+{-# LANGUAGE CPP          #-}
 {-# LANGUAGE LambdaCase   #-}
 {-# LANGUAGE ViewPatterns #-}
 -- | An HLS plugin to provide code actions to change type signatures
 module Ide.Plugin.ChangeTypeSignature (descriptor
                                       -- * For Unit Tests
+                                      , Log(..)
                                       , errorMessageRegexes
                                       ) where
 
-import           Control.Monad                    (guard)
-import           Control.Monad.IO.Class           (MonadIO)
-import           Control.Monad.Trans.Except       (ExceptT)
-import           Data.Foldable                    (asum)
-import qualified Data.Map                         as Map
-import           Data.Maybe                       (mapMaybe)
-import           Data.Text                        (Text)
-import qualified Data.Text                        as T
-import           Development.IDE                  (realSrcSpanToRange)
+import           Control.Lens
+import           Control.Monad                     (guard)
+import           Control.Monad.IO.Class            (MonadIO)
+import           Control.Monad.Trans.Class         (MonadTrans (lift))
+import           Control.Monad.Trans.Except        (ExceptT (..))
+import           Control.Monad.Trans.Maybe         (MaybeT (..), hoistMaybe)
+import           Data.Foldable                     (asum)
+import qualified Data.Map                          as Map
+import           Data.Maybe                        (catMaybes)
+import           Data.Text                         (Text)
+import qualified Data.Text                         as T
+import           Development.IDE                   (FileDiagnostic,
+                                                    IdeState (..), Pretty (..),
+                                                    Priority (..), Recorder,
+                                                    WithPriority,
+                                                    fdLspDiagnosticL,
+                                                    fdStructuredMessageL,
+                                                    logWith, realSrcSpanToRange)
 import           Development.IDE.Core.PluginUtils
-import           Development.IDE.Core.RuleTypes   (GetParsedModule (GetParsedModule))
-import           Development.IDE.Core.Service     (IdeState)
-import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Util         (printOutputable)
-import           Generics.SYB                     (extQ, something)
-import           Ide.Plugin.Error                 (PluginError,
-                                                   getNormalizedFilePathE)
-import           Ide.Types                        (PluginDescriptor (..),
-                                                   PluginId (PluginId),
-                                                   PluginMethodHandler,
-                                                   defaultPluginDescriptor,
-                                                   mkPluginHandler)
+import           Development.IDE.Core.RuleTypes    (GetParsedModule (GetParsedModule))
+import           Development.IDE.GHC.Compat        hiding (vcat)
+import           Development.IDE.GHC.Compat.Error  (_MismatchMessage,
+                                                    _TcRnMessageWithCtx,
+                                                    _TcRnMessageWithInfo,
+                                                    _TcRnSolverReport,
+                                                    _TypeEqMismatchActual,
+                                                    _TypeEqMismatchExpected,
+                                                    msgEnvelopeErrorL,
+                                                    reportContentL)
+import           Development.IDE.GHC.Util          (printOutputable)
+import           Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
+import           Generics.SYB                      (extQ, something)
+import           GHC.Tc.Errors.Types               (ErrInfo (..),
+                                                    TcRnMessageDetailed (..))
+import qualified Ide.Logger                        as Logger
+import           Ide.Plugin.Error                  (PluginError,
+                                                    getNormalizedFilePathE)
+import           Ide.Types                         (Config, HandlerM,
+                                                    PluginDescriptor (..),
+                                                    PluginId (PluginId),
+                                                    PluginMethodHandler,
+                                                    defaultPluginDescriptor,
+                                                    mkPluginHandler)
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import           Text.Regex.TDFA                  ((=~))
-
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
-  { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) }
-
-codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
-codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = do
-      nfp <- getNormalizedFilePathE uri
-      decls <- getDecls plId ideState nfp
-      let actions = mapMaybe (generateAction plId uri decls) diags
-      pure $ InL actions
+import           Text.Regex.TDFA                   ((=~))
+
+data Log
+    = LogErrInfoCtxt ErrInfo
+    | LogFindSigLocFailure DeclName
+
+instance Pretty Log where
+    pretty = \case
+        LogErrInfoCtxt (ErrInfo ctxt suppl) ->
+            Logger.vcat [fromSDoc ctxt, fromSDoc suppl]
+        LogFindSigLocFailure name ->
+            pretty ("Lookup signature location failure: " <> name)
+        where
+            fromSDoc = pretty . printOutputable
+
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder plId =
+    (defaultPluginDescriptor plId "Provides a code action to change the type signature of a binding if it is wrong")
+        { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler recorder plId)
+        }
+
+codeActionHandler
+    :: Recorder (WithPriority Log)
+    -> PluginId
+    -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
+codeActionHandler recorder plId ideState _ CodeActionParams{_textDocument, _range} = do
+    let TextDocumentIdentifier uri = _textDocument
+    nfp <- getNormalizedFilePathE uri
+    decls <- getDecls plId ideState nfp
+
+    activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case
+        Nothing -> pure (InL [])
+        Just fileDiags -> do
+            actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags
+            pure (InL (catMaybes actions))
 
 getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs]
 getDecls (PluginId changeTypeSignatureId) state =
@@ -67,39 +113,74 @@ data ChangeSignature = ChangeSignature {
                          -- | the location of the declaration signature
                          , declSrcSpan :: RealSrcSpan
                          -- | the diagnostic to solve
-                         , diagnostic  :: Diagnostic
+                         , diagnostic  :: FileDiagnostic
                          }
 
 -- | Create a CodeAction from a Diagnostic
-generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction)
-generateAction plId uri decls diag = changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls diag
+generateAction
+    :: Recorder (WithPriority Log)
+    -> PluginId
+    -> Uri
+    -> [LHsDecl GhcPs]
+    -> FileDiagnostic
+    -> HandlerM Config (Maybe (Command |? CodeAction))
+generateAction recorder plId uri decls fileDiag = do
+    changeSig <- diagnosticToChangeSig recorder decls fileDiag
+    pure $
+        changeSigToCodeAction plId uri <$> changeSig
 
 -- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan
-diagnosticToChangeSig :: [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature
-diagnosticToChangeSig decls diagnostic = do
-    -- regex match on the GHC Error Message
-    (expectedType, actualType, declName) <- matchingDiagnostic diagnostic
-    -- Find the definition and it's location
-    declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName)
-    pure $ ChangeSignature{..}
-
+diagnosticToChangeSig
+    :: Recorder (WithPriority Log)
+    -> [LHsDecl GhcPs]
+    -> FileDiagnostic
+    -> HandlerM Config (Maybe ChangeSignature)
+diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do
+    -- Extract expected, actual, and extra error info
+    (expectedType, actualType, errInfo) <- hoistMaybe $ do
+        msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage
+        tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessageWithCtx
+        (_, TcRnMessageDetailed errInfo tcRnMsg') <- tcRnMsg ^? _TcRnMessageWithInfo
+        solverReport <- tcRnMsg' ^? _TcRnSolverReport . _1 . reportContentL
+        mismatch <- solverReport ^? _MismatchMessage
+        expectedType <- mismatch ^? _TypeEqMismatchExpected
+        actualType <- mismatch ^? _TypeEqMismatchActual
+
+        pure (showType expectedType, showType actualType, errInfo)
+
+    logWith recorder Debug (LogErrInfoCtxt errInfo)
+
+    -- Extract the declName from the extra error text
+    declName <- hoistMaybe (matchingDiagnostic errInfo)
+
+    -- Look up location of declName. If it fails, log it
+    declSrcSpan <-
+        case findSigLocOfStringDecl decls expectedType (T.unpack declName) of
+            Just x -> pure x
+            Nothing -> do
+                logWith recorder Debug (LogFindSigLocFailure declName)
+                hoistMaybe Nothing
+
+    pure ChangeSignature{..}
+    where
+        showType :: Type -> Text
+        showType = T.pack . showSDocUnsafe . pprTidiedType
 
 -- | If a diagnostic has the proper message create a ChangeSignature from it
-matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName)
-matchingDiagnostic Diagnostic{_message} = asum $ map (unwrapMatch . (=~) _message) errorMessageRegexes
+matchingDiagnostic :: ErrInfo -> Maybe DeclName
+matchingDiagnostic ErrInfo{errInfoContext} =
+    asum $ map (unwrapMatch . (=~) errInfoTxt) errorMessageRegexes
     where
-        unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName)
-        -- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match
-        unwrapMatch (_, _, _, [expect, actual, _, name]) = Just (expect, actual, name)
-        unwrapMatch _                              = Nothing
+        unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe DeclName
+        unwrapMatch (_, _, _, [name]) = Just name
+        unwrapMatch _                 = Nothing
+
+        errInfoTxt = printOutputable errInfoContext
 
 -- | List of regexes that match various Error Messages
 errorMessageRegexes :: [Text]
 errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests
-    "Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’"
-    , "Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’"
-    -- GHC >9.2 version of the first error regex
-    , "Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’"
+    "In an equation for ‘(.+)’:"
     ]
 
 -- | 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
 changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} =
     InR CodeAction { _title       = mkChangeSigTitle declName actualType
                    , _kind        = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId))
-                   , _diagnostics = Just [diagnostic]
+                   , _diagnostics = Just [diagnostic ^. fdLspDiagnosticL ]
                    , _isPreferred = Nothing
                    , _disabled    = Nothing
                    , _edit        = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType)