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

Author: sgillespie

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,91 @@
+{-# 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  (_TcRnMessage,
+                                                    msgEnvelopeErrorL)
+import           Development.IDE.GHC.Util          (printOutputable)
+import           Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
+import           Generics.SYB                      (extQ, something)
+import           GHC.Tc.Errors.Types               (ErrInfo (..),
+                                                    MismatchMsg (..),
+                                                    SolverReportWithCtxt (..),
+                                                    TcRnMessage (..),
+                                                    TcRnMessageDetailed (..),
+                                                    TcSolverReportMsg (..))
+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                  ((=~))
+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) }
+data Log
+    = LogErrInfoCtxt ErrInfo
+    | LogFindSigLocFailure DeclName
 
-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
+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 +111,104 @@ 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 ^? _TcRnMessage
+        (solverReport, errInfo) <- findSolverReport tcRnMsg
+        mismatch <- findMismatchMessage solverReport
+        (expectedType', actualType') <- findTypeEqMismatch mismatch
+        errInfo' <- errInfo
+
+        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
+
+-- TODO: Make this a prism?
+findSolverReport :: TcRnMessage -> Maybe (TcSolverReportMsg, Maybe ErrInfo)
+findSolverReport (TcRnMessageWithInfo _ (TcRnMessageDetailed errInfo msg)) =
+    case findSolverReport msg of
+        Just (mismatch, _) -> Just (mismatch, Just errInfo)
+        _                  -> Nothing
+#if MIN_VERSION_ghc(9,10,0)
+findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _) =
+    Just (mismatch, Nothing)
+#else
+findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _ _) =
+    Just (mismatch, Nothing)
+#endif
+findSolverReport _ = Nothing
+
+-- TODO: Make this a prism?
+findMismatchMessage :: TcSolverReportMsg -> Maybe MismatchMsg
+findMismatchMessage (Mismatch m _ _ _)        = Just m
+findMismatchMessage (CannotUnifyVariable m _) = Just m
+findMismatchMessage _                         = Nothing
+
+-- TODO: Make this a prism?
+findTypeEqMismatch :: MismatchMsg -> Maybe (Type, Type)
+#if MIN_VERSION_ghc(9,12,0)
+findTypeEqMismatch (TypeEqMismatch _ _ _ expected actual _ _) = Just (expected, actual)
+#else
+findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) = Just (expected, actual)
+#endif
+findTypeEqMismatch _ = Nothing
 
 -- | 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 ‘(.+)’:" -- TODO: Check if this is useful only for tests
+    , "In an equation for `(.+)':"
     ]
 
 -- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches
@@ -147,7 +256,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)

plugins/hls-change-type-signature-plugin/test/Main.hs

@@ -5,7 +5,7 @@ import           Data.Either                    (rights)
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
 import qualified Data.Text.IO                   as TIO
-import           Ide.Plugin.ChangeTypeSignature (errorMessageRegexes)
+import           Ide.Plugin.ChangeTypeSignature (Log (..), errorMessageRegexes)
 import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature
 import           System.FilePath                ((<.>), (</>))
 import           Test.Hls                       (CodeAction (..), Command,
@@ -21,8 +21,7 @@ import           Test.Hls                       (CodeAction (..), Command,
                                                  getCodeActions,
                                                  goldenWithHaskellDoc,
                                                  knownBrokenForGhcVersions,
-                                                 liftIO,
-                                                 mkPluginTestDescriptor',
+                                                 liftIO, mkPluginTestDescriptor,
                                                  openDoc, runSessionWithServer,
                                                  testCase, testGroup, toEither,
                                                  type (|?), waitForBuildQueue,
@@ -32,16 +31,19 @@ import           Text.Regex.TDFA                ((=~))
 main :: IO ()
 main = defaultTestRunner test
 
-changeTypeSignaturePlugin :: PluginTestDescriptor ()
-changeTypeSignaturePlugin = mkPluginTestDescriptor' ChangeTypeSignature.descriptor "changeTypeSignature"
+changeTypeSignaturePlugin :: PluginTestDescriptor Log
+changeTypeSignaturePlugin =
+    mkPluginTestDescriptor
+        ChangeTypeSignature.descriptor
+        "changeTypeSignature"
 
 test :: TestTree
 test = testGroup "changeTypeSignature" [
         testRegexes
         , codeActionTest "TExpectedActual" 4 11
-        , knownBrokenForGhcVersions [GHC96 .. GHC912] "Error Message in 9.2+ does not provide enough info" $
+        , knownBrokenForGhcVersions [GHC96 .. GHC912] "Error Message in 9.6+ does not provide enough info" $
             codeActionTest "TRigidType" 4 14
-        , codeActionTest "TRigidType2" 4 6
+        , codeActionTest "TRigidType2" 4 8
         , codeActionTest "TLocalBinding" 7 22
         , codeActionTest "TLocalBindingShadow1" 11 8
         , codeActionTest "TLocalBindingShadow2" 7 22
@@ -50,43 +52,17 @@ test = testGroup "changeTypeSignature" [
 
 testRegexes :: TestTree
 testRegexes = testGroup "Regex Testing" [
-        testRegexOne
-        , testRegexTwo
-        , testRegex921One
-    ]
-
-testRegexOne :: TestTree
-testRegexOne = testGroup "Regex One" [
-        regexTest "error1.txt" regex True
-        , regexTest "error2.txt" regex True
-        , regexTest "error3.txt" regex False
-        , regexTest "error4.txt" regex True
-        , regexTest "error5.txt" regex True
+        regexTest "TExpectedActual.txt" regex True
+        , regexTest "TLocalBinding.txt" regex True
+        , regexTest "TLocalBindingShadow1.txt" regex True
+        , regexTest "TLocalBindingShadow2.txt" regex True
+        -- Error message from GHC currently does not not provide enough info
+        , regexTest "TRigidType.txt" regex False
+        , regexTest "TRigidType2.txt" regex True
     ]
     where
         regex = errorMessageRegexes !! 0
 
-testRegexTwo :: TestTree
-testRegexTwo = testGroup "Regex Two" [
-        regexTest "error1.txt" regex False
-        , regexTest "error2.txt" regex False
-        , regexTest "error3.txt" regex True
-        , regexTest "error4.txt" regex False
-        , regexTest "error5.txt" regex False
-    ]
-    where
-        regex = errorMessageRegexes !! 1
-
--- test ghc-9.2 error message regex
-testRegex921One :: TestTree
-testRegex921One = testGroup "Regex One" [
-        regexTest "ghc921-error1.txt" regex True
-        , regexTest "ghc921-error2.txt" regex True
-        , regexTest "ghc921-error3.txt" regex True
-    ]
-    where
-        regex = errorMessageRegexes !! 2
-
 testDataDir :: FilePath
 testDataDir = "plugins" </> "hls-change-type-signature-plugin" </> "test" </> "testdata"
 
@@ -123,8 +99,8 @@ regexTest :: FilePath -> Text -> Bool -> TestTree
 regexTest fp regex shouldPass = testCase fp $ do
     msg <- TIO.readFile (testDataDir </> fp)
     case (msg =~ regex  :: (Text, Text, Text, [Text]), shouldPass) of
-        ((_, _, _, [_, _, _, _]), True) -> pure ()
-        ((_, _, _, [_, _, _, _]), False) -> assertFailure $  "Unexpected match: " <> fp <> " with " <> T.unpack regex
+        ((_, _, _, [_]), True) -> pure ()
+        ((_, _, _, [_]), False) -> assertFailure $  "Unexpected match: " <> fp <> " with " <> T.unpack regex
         (_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex
         (_, False) -> pure ()
 

plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.txt

@@ -0,0 +1,8 @@
+In the expression: go
+In an equation for ‘fullSig’:
+fullSig
+      = go
+      where
+          go = head . reverse
+
+