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

haskell-language-server.cabal

@@ -1168,12 +1168,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
@@ -1191,6 +1193,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

@@ -3,45 +3,92 @@
 -- | An HLS plugin to provide code actions to change type signatures
 module Ide.Plugin.ChangeTypeSignature (descriptor
                                       -- * For Unit Tests
+                                      , Log(..)
                                       , errorMessageRegexes
                                       ) where
 
+import           Control.Lens
 import           Control.Monad                    (guard)
 import           Control.Monad.IO.Class           (MonadIO)
-import           Control.Monad.Trans.Except       (ExceptT)
+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                       (mapMaybe)
+import           Data.Maybe                       (catMaybes)
 import           Data.Text                        (Text)
 import qualified Data.Text                        as T
-import           Development.IDE                  (realSrcSpanToRange)
+import           Development.IDE                  (realSrcSpanToRange,
+                                                   IdeState (..),
+                                                   FileDiagnostic,
+                                                   fdLspDiagnosticL,
+                                                   fdStructuredMessageL,
+                                                   logWith,
+                                                   Pretty (..),
+                                                   Priority (..),
+                                                   Recorder,
+                                                   WithPriority)
 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.Compat       hiding (vcat)
 import           Development.IDE.GHC.Util         (printOutputable)
+import           Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
+import           Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage)
 import           Generics.SYB                     (extQ, something)
+import           GHC.Tc.Errors.Types              (TcSolverReportMsg(..),
+                                                   TcRnMessage (..),
+                                                   TcRnMessage (..),
+                                                   SolverReportWithCtxt (..),
+                                                   TcRnMessageDetailed (..),
+                                                   MismatchMsg (..),
+                                                   ErrInfo (..))
+import qualified Ide.Logger as Logger
 import           Ide.Plugin.Error                 (PluginError,
                                                    getNormalizedFilePathE)
 import           Ide.Types                        (PluginDescriptor (..),
                                                    PluginId (PluginId),
                                                    PluginMethodHandler,
                                                    defaultPluginDescriptor,
-                                                   mkPluginHandler)
+                                                   mkPluginHandler,
+                                                   HandlerM,
+                                                   Config)
 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) }
+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 +114,93 @@
                          -- | 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
+    (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 Development.IDE.Warning (LogErrInfoCtxt errInfo)
+
+    declName <- hoistMaybe (matchingDiagnostic errInfo)
 
+    declSrcSpan <-
+        case findSigLocOfStringDecl decls expectedType (T.unpack declName) of
+            Just x -> pure x
+            Nothing -> do
+                logWith recorder Development.IDE.Warning (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
+findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _ _) =
+    Just (mismatch, Nothing)
+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)
+findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) =
+    Just (expected, actual)
+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 +248,7 @@
 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,
@@ -22,18 +22,20 @@ import           Test.Hls                       (CodeAction (..), Command,
                                                  goldenWithHaskellDoc,
                                                  knownBrokenForGhcVersions,
                                                  liftIO,
-                                                 mkPluginTestDescriptor',
                                                  openDoc, runSessionWithServer,
                                                  testCase, testGroup, toEither,
                                                  type (|?), waitForBuildQueue,
-                                                 waitForDiagnostics, (@?=))
+                                                 waitForDiagnostics, (@?=), mkPluginTestDescriptor)
 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" [
@@ -50,33 +52,16 @@ 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
+        , 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" [
@@ -85,7 +70,7 @@ testRegex921One = testGroup "Regex One" [
         , regexTest "ghc921-error3.txt" regex True
     ]
     where
-        regex = errorMessageRegexes !! 2
+        regex = errorMessageRegexes !! 0
 
 testDataDir :: FilePath
 testDataDir = "plugins" </> "hls-change-type-signature-plugin" </> "test" </> "testdata"
@@ -123,8 +108,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
+
+

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

@@ -0,0 +1,8 @@
+Probable cause: ‘forM’ is applied to too few arguments
+In the expression: forM
+In an equation for ‘test’: test = forM
+In the expression:
+  let
+    test :: Int -> Int
+    test = forM
+  in x + 1

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

@@ -0,0 +1,4 @@
+Probable cause: ‘forM’ is applied to too few arguments
+In the expression: forM
+In an equation for ‘test’: test = forM
+

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

@@ -0,0 +1,9 @@
+Probable cause: ‘forM’ is applied to too few arguments
+In the expression: forM
+In an equation for ‘test’: test = forM
+In the expression:
+  let
+    test :: Int -> Int
+    test = forM
+  in test x [GHC-83865]
+

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

@@ -0,0 +1,13 @@
+Expected: a -> [[Int]]
+  Actual: [[Int]] -> [[Int]]
+‘a’ is a rigid type variable bound by
+  the type signature for:
+    test :: forall a. a -> Int
+  at /home/sgillespie/dev/haskell/haskell-language-server/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs:3:1-16
+In the second argument of ‘(.)’, namely ‘reverse’
+In the second argument of ‘(.)’, namely ‘head . reverse’
+In the expression: go . head . reverse
+Relevant bindings include
+  test :: a -> Int
+    (bound at /home/sgillespie/dev/haskell/haskell-language-server/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs:4:1) [GHC-25897]
+