From c26a6ec936c0b8b0f051e26fd1d212f6ee6357b9 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Wed, 11 Jun 2025 14:19:20 -0400 Subject: [PATCH 1/4] Migrate change-type-signature-plugin to use structured diagnostics --- haskell-language-server.cabal | 3 + .../src/Ide/Plugin/ChangeTypeSignature.hs | 213 +++++++++++++----- .../test/Main.hs | 60 ++--- .../test/testdata/TExpectedActual.txt | 8 + .../test/testdata/TLocalBinding.txt | 8 + .../test/testdata/TLocalBindingShadow1.txt | 4 + .../test/testdata/TLocalBindingShadow2.txt | 9 + .../test/testdata/TRigidType.txt | 5 + .../test/testdata/TRigidType2.txt | 6 + .../test/testdata/error1.txt | 6 - .../test/testdata/error2.txt | 6 - .../test/testdata/error3.txt | 10 - .../test/testdata/error4.txt | 19 -- .../test/testdata/error5.txt | 15 -- src/HlsPlugins.hs | 2 +- 15 files changed, 223 insertions(+), 151 deletions(-) create mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.txt create mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.txt create mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.txt create mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.txt create mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt create mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt delete mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/error1.txt delete mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/error2.txt delete mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/error3.txt delete mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/error4.txt delete mode 100644 plugins/hls-change-type-signature-plugin/test/testdata/error5.txt diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 42e8d11b60..ec397952cb 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index df776e6d15..41129ea9ae 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/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) diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index cd1b152c0b..72a2ab780e 100644 --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/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 () diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.txt new file mode 100644 index 0000000000..6a8246a921 --- /dev/null +++ b/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 + + diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.txt new file mode 100644 index 0000000000..3f31dc48b9 --- /dev/null +++ b/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 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.txt new file mode 100644 index 0000000000..ef782e8aec --- /dev/null +++ b/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 + diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.txt new file mode 100644 index 0000000000..bea2526eb9 --- /dev/null +++ b/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] + diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt new file mode 100644 index 0000000000..f9e78c97ae --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt @@ -0,0 +1,5 @@ +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] + diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt new file mode 100644 index 0000000000..343129a942 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt @@ -0,0 +1,6 @@ +In the expression: head +In an equation for ‘test’: test = head +Relevant bindings include + test :: a -> Int + (bound at /home/sgillespie/dev/haskell/haskell-language-server/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.hs:4:1) [GHC-25897] + diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt deleted file mode 100644 index 37f0aa4a81..0000000000 --- a/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt +++ /dev/null @@ -1,6 +0,0 @@ - • Couldn't match type ‘Int’ - with ‘Data.HashSet.Internal.HashSet Int’ - Expected type: Int -> Int - Actual type: Data.HashSet.Internal.HashSet Int -> Int - • In the expression: head . toList - In an equation for ‘test’: test = head . toList diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt deleted file mode 100644 index 497f8350a5..0000000000 --- a/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt +++ /dev/null @@ -1,6 +0,0 @@ - • Couldn't match type ‘b0 -> t0 a0 -> b0’ with ‘Int’ - Expected type: Int -> Int - Actual type: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0 - • Probable cause: ‘foldl’ is applied to too few arguments - In the expression: foldl - In an equation for ‘test’: test = foldl diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt deleted file mode 100644 index 0cbddad7c4..0000000000 --- a/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt +++ /dev/null @@ -1,10 +0,0 @@ - • Couldn't match expected type ‘Int’ with actual type ‘[Int]’ - • In the expression: map (+ x) [1, 2, 3] - In an equation for ‘test’: - test x - = map (+ x) [1, 2, 3] - where - go = head . reverse - | -152 | test x = map (+ x) [1,2,3] - | ^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt deleted file mode 100644 index 323cf7d4db..0000000000 --- a/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt +++ /dev/null @@ -1,19 +0,0 @@ - • Couldn't match type ‘a’ with ‘[[Int]]’ - ‘a’ is a rigid type variable bound by - the type signature for: - test :: forall a. Ord a => a -> Int - at src/Ide/Plugin/ChangeTypeSignature.hs:154:1-25 - Expected type: a -> Int - Actual type: [[Int]] -> Int - • In the expression: go . head . reverse - In an equation for ‘test’: - test - = go . head . reverse - where - go = head . reverse - • Relevant bindings include - test :: a -> Int - (bound at src/Ide/Plugin/ChangeTypeSignature.hs:155:1) - | -155 | test = go . head . reverse - | ^^^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt deleted file mode 100644 index a7a5d9a20b..0000000000 --- a/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt +++ /dev/null @@ -1,15 +0,0 @@ - • Couldn't match type ‘(a0 -> m0 b0) -> m0 (t0 b0)’ with ‘Int’ - Expected type: Int -> Int - Actual type: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) - • Probable cause: ‘forM’ is applied to too few arguments - In the expression: forM - In an equation for ‘test’: test = forM - In an equation for ‘implicit’: - implicit - = return OpTEmpty - where - test :: Int -> Int - test = forM - | -82 | test = forM - | ^^^^ diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 87a1af7392..4c135fc48b 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -224,7 +224,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "codeRange" in CodeRange.descriptor (pluginRecorder pId) pId: #endif #if hls_changeTypeSignature - ChangeTypeSignature.descriptor "changeTypeSignature" : + let pId = "changeTypeSignature" in ChangeTypeSignature.descriptor (pluginRecorder pId) pId : #endif #if hls_gadt GADT.descriptor "gadt" : From fc362415743507a78cba48f2b3b560d6d6f5731b Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 17 Jun 2025 22:30:27 -0400 Subject: [PATCH 2/4] Refactor: Turn some getter functions into Lenses/Treversals --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 69 +++++++++++-------- 1 file changed, 41 insertions(+), 28 deletions(-) diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index 41129ea9ae..30d48067ba 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -138,12 +138,13 @@ 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 + TcRnMessageDetailed errInfo tcRnMsg' <- tcRnMsg ^? _TcRnMessageDetailed + solverReport <- tcRnMsg' ^? _TcRnSolverReport . tcSolverReportMsgL + mismatch <- solverReport ^? _MismatchMessage + expectedType <- mismatch ^? _TypeEqMismatchExpected + actualType <- mismatch ^? _TypeEqMismatchActual - pure (showType expectedType', showType actualType', errInfo') + pure (showType expectedType, showType actualType, errInfo) logWith recorder Debug (LogErrInfoCtxt errInfo) @@ -163,35 +164,48 @@ diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do 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 +_TcRnMessageDetailed :: Traversal' TcRnMessage TcRnMessageDetailed +_TcRnMessageDetailed focus (TcRnMessageWithInfo errInfo detailed) = + (\detailed' -> TcRnMessageWithInfo errInfo detailed') <$> focus detailed +_TcRnMessageDetailed _ msg = pure msg + +_TcRnSolverReport :: Traversal' TcRnMessage SolverReportWithCtxt #if MIN_VERSION_ghc(9,10,0) -findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _) = - Just (mismatch, Nothing) +_TcRnSolverReport focus (TcRnSolverReport report reason) = + (\report' -> TcRnSolverReport report' reason) <$> focus report #else -findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _ _) = - Just (mismatch, Nothing) +_TcRnSolverReport focus (TcRnSolverReport report reason hints) = + (\report' -> TcRnSolverReport report' reason hints) <$> focus report #endif -findSolverReport _ = Nothing +_TcRnSolverReport _ msg = pure msg + +tcSolverReportMsgL :: Lens' SolverReportWithCtxt TcSolverReportMsg +tcSolverReportMsgL = lens reportContent (\report content' -> report { reportContent = content' }) + +_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 --- TODO: Make this a prism? -findMismatchMessage :: TcSolverReportMsg -> Maybe MismatchMsg -findMismatchMessage (Mismatch m _ _ _) = Just m -findMismatchMessage (CannotUnifyVariable m _) = Just m -findMismatchMessage _ = Nothing +_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 --- TODO: Make this a prism? -findTypeEqMismatch :: MismatchMsg -> Maybe (Type, Type) +_TypeEqMismatchActual :: Traversal' MismatchMsg Type #if MIN_VERSION_ghc(9,12,0) -findTypeEqMismatch (TypeEqMismatch _ _ _ expected actual _ _) = Just (expected, actual) +_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) = + (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual #else -findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) = Just (expected, actual) +_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) = + (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual #endif -findTypeEqMismatch _ = Nothing +_TypeEqMismatchActual _ mismatch = pure mismatch -- | If a diagnostic has the proper message create a ChangeSignature from it matchingDiagnostic :: ErrInfo -> Maybe DeclName @@ -207,8 +221,7 @@ matchingDiagnostic ErrInfo{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 - "In an equation for ‘(.+)’:" -- TODO: Check if this is useful only for tests - , "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 From b87513ea44903e1de7da3b201551126c47abac9e Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Wed, 18 Jun 2025 10:08:47 -0400 Subject: [PATCH 3/4] fix: Use updated traversal for error messages _TcRnMessage -> _TcRnMessageWithCtx --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index 30d48067ba..2f3a1f21a6 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -29,7 +29,7 @@ import Development.IDE (FileDiagnostic, import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) import Development.IDE.GHC.Compat hiding (vcat) -import Development.IDE.GHC.Compat.Error (_TcRnMessage, +import Development.IDE.GHC.Compat.Error (_TcRnMessageWithCtx, msgEnvelopeErrorL) import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Types.Diagnostics (_SomeStructuredMessage) @@ -137,7 +137,7 @@ 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 + tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessageWithCtx TcRnMessageDetailed errInfo tcRnMsg' <- tcRnMsg ^? _TcRnMessageDetailed solverReport <- tcRnMsg' ^? _TcRnSolverReport . tcSolverReportMsgL mismatch <- solverReport ^? _MismatchMessage From 6f1dcc771664082ee9bfbc7210d43d7038d26875 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Fri, 20 Jun 2025 22:41:58 -0400 Subject: [PATCH 4/4] Refactor: Extract additional Prisms/Lenses into a common module --- .../src/Development/IDE/GHC/Compat/Error.hs | 43 ++++++++++++- .../src/Ide/Plugin/ChangeTypeSignature.hs | 63 ++++--------------- 2 files changed, 53 insertions(+), 53 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs index 0255886726..01abbf1a66 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Error.hs +++ b/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 diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index 2f3a1f21a6..8b8b7e7d3a 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -29,17 +29,19 @@ import Development.IDE (FileDiagnostic, import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) import Development.IDE.GHC.Compat hiding (vcat) -import Development.IDE.GHC.Compat.Error (_TcRnMessageWithCtx, - msgEnvelopeErrorL) +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 (..), - MismatchMsg (..), - SolverReportWithCtxt (..), - TcRnMessage (..), - TcRnMessageDetailed (..), - TcSolverReportMsg (..)) + TcRnMessageDetailed (..)) import qualified Ide.Logger as Logger import Ide.Plugin.Error (PluginError, getNormalizedFilePathE) @@ -138,8 +140,8 @@ diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do (expectedType, actualType, errInfo) <- hoistMaybe $ do msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessageWithCtx - TcRnMessageDetailed errInfo tcRnMsg' <- tcRnMsg ^? _TcRnMessageDetailed - solverReport <- tcRnMsg' ^? _TcRnSolverReport . tcSolverReportMsgL + (_, TcRnMessageDetailed errInfo tcRnMsg') <- tcRnMsg ^? _TcRnMessageWithInfo + solverReport <- tcRnMsg' ^? _TcRnSolverReport . _1 . reportContentL mismatch <- solverReport ^? _MismatchMessage expectedType <- mismatch ^? _TypeEqMismatchExpected actualType <- mismatch ^? _TypeEqMismatchActual @@ -164,49 +166,6 @@ diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do showType :: Type -> Text showType = T.pack . showSDocUnsafe . pprTidiedType -_TcRnMessageDetailed :: Traversal' TcRnMessage TcRnMessageDetailed -_TcRnMessageDetailed focus (TcRnMessageWithInfo errInfo detailed) = - (\detailed' -> TcRnMessageWithInfo errInfo detailed') <$> focus detailed -_TcRnMessageDetailed _ msg = pure msg - -_TcRnSolverReport :: Traversal' TcRnMessage SolverReportWithCtxt -#if MIN_VERSION_ghc(9,10,0) -_TcRnSolverReport focus (TcRnSolverReport report reason) = - (\report' -> TcRnSolverReport report' reason) <$> focus report -#else -_TcRnSolverReport focus (TcRnSolverReport report reason hints) = - (\report' -> TcRnSolverReport report' reason hints) <$> focus report -#endif -_TcRnSolverReport _ msg = pure msg - -tcSolverReportMsgL :: Lens' SolverReportWithCtxt TcSolverReportMsg -tcSolverReportMsgL = lens reportContent (\report content' -> report { reportContent = content' }) - -_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 - -_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 - -_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 - -- | If a diagnostic has the proper message create a ChangeSignature from it matchingDiagnostic :: ErrInfo -> Maybe DeclName matchingDiagnostic ErrInfo{errInfoContext} =