From d90e73efd637cf382c9fd52561f656210d29f5de Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Wed, 11 Jun 2025 14:19:20 -0400 Subject: [PATCH 01/10] Migrate change-type-signature-plugin to use structured diagnostics --- haskell-language-server.cabal | 2 + .../src/Ide/Plugin/ChangeTypeSignature.hs | 95 ++++++++++++++----- 2 files changed, 71 insertions(+), 26 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index fd14c7f5b9..f18d515e5b 100644 --- a/haskell-language-server.cabal +++ b/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 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..4c82255025 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 @@ -6,6 +6,7 @@ module Ide.Plugin.ChangeTypeSignature (descriptor , errorMessageRegexes ) where +import Control.Lens import Control.Monad (guard) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Except (ExceptT) @@ -14,10 +15,9 @@ 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 Development.IDE (realSrcSpanToRange, IdeState (..), FileDiagnostic, fdLspDiagnosticL, fdStructuredMessageL) 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) @@ -31,17 +31,25 @@ import Ide.Types (PluginDescriptor (..), import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Text.Regex.TDFA ((=~)) +import Development.IDE.Types.Diagnostics (_SomeStructuredMessage) +import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage) +import GHC.Tc.Errors.Types (TcSolverReportMsg(..), TcRnMessage (..), TcRnMessage (..), SolverReportWithCtxt (..), TcRnMessageDetailed (..), MismatchMsg (..), ErrInfo (..)) 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 +codeActionHandler 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 + let actions = mapMaybe (generateAction plId uri decls) fileDiags + pure (InL actions) getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state = @@ -67,39 +75,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 :: PluginId -> Uri -> [LHsDecl GhcPs] -> FileDiagnostic -> Maybe (Command |? CodeAction) +generateAction plId uri decls fileDiag = + changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls fileDiag -- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan -diagnosticToChangeSig :: [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature +diagnosticToChangeSig :: [LHsDecl GhcPs] -> FileDiagnostic -> 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 + msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage + tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessage + (solverReport, errInfo) <- findSolverReport tcRnMsg + mismatch <- findMismatchMessage solverReport + (expectedType', actualType') <- findTypeEqMismatch mismatch + errInfo' <- errInfo + + let expectedType = showType expectedType' + actualType = showType actualType' + + declName <- matchingDiagnostic errInfo' declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName) - pure $ ChangeSignature{..} + Just (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 _ = 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 + + -- TODO: Unsafe? + errInfoTxt = T.pack $ showSDocUnsafe 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 +190,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) From f5ae504434d9dc1f9d71744f161218ec35cb0772 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Sun, 15 Jun 2025 18:42:27 -0400 Subject: [PATCH 02/10] chore: Add logging to `change-type-signature-plugin` --- haskell-language-server.cabal | 1 + .../src/Ide/Plugin/ChangeTypeSignature.hs | 124 +++++++++++++----- src/HlsPlugins.hs | 2 +- 3 files changed, 93 insertions(+), 34 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f18d515e5b..32022d37a6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1193,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 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 4c82255025..e14e45adc2 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 @@ -3,44 +3,83 @@ -- | 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 (mapMaybe, catMaybes) import Data.Text (Text) import qualified Data.Text as T -import Development.IDE (realSrcSpanToRange, IdeState (..), FileDiagnostic, fdLspDiagnosticL, fdStructuredMessageL) +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.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 ((=~)) -import Development.IDE.Types.Diagnostics (_SomeStructuredMessage) -import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL, _TcRnMessage) -import GHC.Tc.Errors.Types (TcSolverReportMsg(..), TcRnMessage (..), TcRnMessage (..), SolverReportWithCtxt (..), TcRnMessageDetailed (..), MismatchMsg (..), ErrInfo (..)) -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, _range} = do +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 @@ -48,8 +87,8 @@ codeActionHandler plId ideState _ CodeActionParams{_textDocument, _range} = do activeDiagnosticsInRange (shakeExtras ideState) nfp _range >>= \case Nothing -> pure (InL []) Just fileDiags -> do - let actions = mapMaybe (generateAction plId uri decls) fileDiags - pure (InL actions) + 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 = @@ -79,28 +118,48 @@ data ChangeSignature = ChangeSignature { } -- | Create a CodeAction from a Diagnostic -generateAction :: PluginId -> Uri -> [LHsDecl GhcPs] -> FileDiagnostic -> Maybe (Command |? CodeAction) -generateAction plId uri decls fileDiag = - changeSigToCodeAction plId uri <$> diagnosticToChangeSig decls fileDiag +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] -> FileDiagnostic -> Maybe ChangeSignature -diagnosticToChangeSig decls diagnostic = do - msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage - tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessage - (solverReport, errInfo) <- findSolverReport tcRnMsg - mismatch <- findMismatchMessage solverReport - (expectedType', actualType') <- findTypeEqMismatch mismatch - errInfo' <- errInfo +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') - let expectedType = showType expectedType' - actualType = showType actualType' + logWith recorder Development.IDE.Warning (LogErrInfoCtxt errInfo) - declName <- matchingDiagnostic errInfo' - declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName) + 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 - Just (ChangeSignature{..}) + pure ChangeSignature{..} where showType :: Type -> Text showType = T.pack . showSDocUnsafe . pprTidiedType @@ -135,8 +194,7 @@ matchingDiagnostic ErrInfo{errInfoContext} = unwrapMatch (_, _, _, [name]) = Just name unwrapMatch _ = Nothing - -- TODO: Unsafe? - errInfoTxt = T.pack $ showSDocUnsafe errInfoContext + errInfoTxt = printOutputable errInfoContext -- | List of regexes that match various Error Messages errorMessageRegexes :: [Text] 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 439c4be439b967452d348f0ba270f94d019afa1b Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Jun 2025 09:38:45 -0400 Subject: [PATCH 03/10] test: Overhaul regex tests for `change-type-signature-plugin` --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 4 +- .../test/Main.hs | 47 +++++++------------ .../test/testdata/TExpectedActual.txt | 8 ++++ .../test/testdata/TLocalBinding.txt | 8 ++++ .../test/testdata/TLocalBindingShadow1.txt | 4 ++ .../test/testdata/TLocalBindingShadow2.txt | 9 ++++ .../test/testdata/TRigidType.txt | 13 +++++ .../test/testdata/TRigidType2.txt | 13 +++++ .../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 ------ 13 files changed, 73 insertions(+), 89 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/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index e14e45adc2..1d6ef869a9 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 @@ -15,7 +15,7 @@ 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, catMaybes) +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import Development.IDE (realSrcSpanToRange, @@ -130,7 +130,6 @@ generateAction recorder plId uri decls fileDiag = do pure $ changeSigToCodeAction plId uri <$> changeSig - -- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan diagnosticToChangeSig :: Recorder (WithPriority Log) @@ -177,6 +176,7 @@ 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? diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index cd1b152c0b..16b2c839ab 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, @@ -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 () 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..2fef978e73 --- /dev/null +++ b/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] + 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..56303b52f3 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt @@ -0,0 +1,13 @@ +Couldn't match type ‘a’ with ‘[Int]’ +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/TRigidType2.hs:3:1-16 +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 - | ^^^^ From a3e96c1efbc1e5c9aeb7e752e629f7e6674dcbf5 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Jun 2025 09:46:44 -0400 Subject: [PATCH 04/10] test: Make regex tests match diagnostics --- .../test/testdata/TRigidType.txt | 8 -------- .../test/testdata/TRigidType2.txt | 7 ------- 2 files changed, 15 deletions(-) diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt index 2fef978e73..f9e78c97ae 100644 --- a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.txt @@ -1,11 +1,3 @@ -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 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt index 56303b52f3..343129a942 100644 --- a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType2.txt @@ -1,10 +1,3 @@ -Couldn't match type ‘a’ with ‘[Int]’ -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/TRigidType2.hs:3:1-16 In the expression: head In an equation for ‘test’: test = head Relevant bindings include From b7e7e7a117cb06ec561ecf7a5f01b83e7e205830 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Jun 2025 21:32:50 -0400 Subject: [PATCH 05/10] test: Remove unuseful tests --- .../hls-change-type-signature-plugin/test/Main.hs | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index 16b2c839ab..4e6e5fe631 100644 --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -41,9 +41,9 @@ 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 @@ -56,22 +56,13 @@ testRegexes = testGroup "Regex Testing" [ , 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 --- 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 !! 0 - testDataDir :: FilePath testDataDir = "plugins" "hls-change-type-signature-plugin" "test" "testdata" From 7593baa404227d7a22bdfd61da8026b627077309 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Jun 2025 21:33:19 -0400 Subject: [PATCH 06/10] fix: Fix build for GHC 9.10, 9.12 --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 9 +++++++++ 1 file changed, 9 insertions(+) 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 1d6ef869a9..11c5b26e63 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} -- | An HLS plugin to provide code actions to change type signatures @@ -169,7 +170,11 @@ 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) _) = +#else findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _ _) = +#endif Just (mismatch, Nothing) findSolverReport _ = Nothing @@ -181,7 +186,11 @@ findMismatchMessage _ = Nothing -- TODO: Make this a prism? findTypeEqMismatch :: MismatchMsg -> Maybe (Type, Type) +#if MIN_VERSION_ghc(9,12,0) +findTypeEqMismatch (TypeEqMismatch _ _ _ expected actual _ _) = +#else findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) = +#endif Just (expected, actual) findTypeEqMismatch _ = Nothing From ff6b8d83124e266a866766d088f8e19f54b3b376 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Jun 2025 21:50:02 -0400 Subject: [PATCH 07/10] fix: stylish haskell --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 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 11c5b26e63..62bf526b5b 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 @@ -172,10 +172,11 @@ findSolverReport (TcRnMessageWithInfo _ (TcRnMessageDetailed errInfo msg)) = _ -> Nothing #if MIN_VERSION_ghc(9,10,0) findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _) = + Just (mismatch, Nothing) #else findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _ _) = -#endif Just (mismatch, Nothing) +#endif findSolverReport _ = Nothing -- TODO: Make this a prism? @@ -187,11 +188,10 @@ findMismatchMessage _ = Nothing -- TODO: Make this a prism? findTypeEqMismatch :: MismatchMsg -> Maybe (Type, Type) #if MIN_VERSION_ghc(9,12,0) -findTypeEqMismatch (TypeEqMismatch _ _ _ expected actual _ _) = +findTypeEqMismatch (TypeEqMismatch _ _ _ expected actual _ _) = Just (expected, actual) #else -findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) = +findTypeEqMismatch (TypeEqMismatch _ _ _ _ expected actual _ _) = Just (expected, actual) #endif - Just (expected, actual) findTypeEqMismatch _ = Nothing -- | If a diagnostic has the proper message create a ChangeSignature from it From ed4d061c19e105df5a4c6e2f9adc7c5bdbff0b3f Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Jun 2025 21:53:00 -0400 Subject: [PATCH 08/10] fix: stylish-haskell --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 90 +++++++++---------- .../test/Main.hs | 6 +- 2 files changed, 46 insertions(+), 50 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 62bf526b5b..65002641d4 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,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} -- | An HLS plugin to provide code actions to change type signatures @@ -9,53 +9,49 @@ module Ide.Plugin.ChangeTypeSignature (descriptor ) where 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 (realSrcSpanToRange, - IdeState (..), - FileDiagnostic, - fdLspDiagnosticL, - fdStructuredMessageL, - logWith, - Pretty (..), - Priority (..), - Recorder, - WithPriority) +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.GHC.Compat hiding (vcat) -import Development.IDE.GHC.Util (printOutputable) +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 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, - HandlerM, - Config) +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 ((=~)) data Log = LogErrInfoCtxt ErrInfo @@ -169,7 +165,7 @@ findSolverReport :: TcRnMessage -> Maybe (TcSolverReportMsg, Maybe ErrInfo) findSolverReport (TcRnMessageWithInfo _ (TcRnMessageDetailed errInfo msg)) = case findSolverReport msg of Just (mismatch, _) -> Just (mismatch, Just errInfo) - _ -> Nothing + _ -> Nothing #if MIN_VERSION_ghc(9,10,0) findSolverReport (TcRnSolverReport (SolverReportWithCtxt _ mismatch) _) = Just (mismatch, Nothing) @@ -181,9 +177,9 @@ findSolverReport _ = Nothing -- TODO: Make this a prism? findMismatchMessage :: TcSolverReportMsg -> Maybe MismatchMsg -findMismatchMessage (Mismatch m _ _ _) = Just m +findMismatchMessage (Mismatch m _ _ _) = Just m findMismatchMessage (CannotUnifyVariable m _) = Just m -findMismatchMessage _ = Nothing +findMismatchMessage _ = Nothing -- TODO: Make this a prism? findTypeEqMismatch :: MismatchMsg -> Maybe (Type, Type) diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index 4e6e5fe631..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 (Log(..), errorMessageRegexes) +import Ide.Plugin.ChangeTypeSignature (Log (..), errorMessageRegexes) import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature import System.FilePath ((<.>), ()) import Test.Hls (CodeAction (..), Command, @@ -21,11 +21,11 @@ import Test.Hls (CodeAction (..), Command, getCodeActions, goldenWithHaskellDoc, knownBrokenForGhcVersions, - liftIO, + liftIO, mkPluginTestDescriptor, openDoc, runSessionWithServer, testCase, testGroup, toEither, type (|?), waitForBuildQueue, - waitForDiagnostics, (@?=), mkPluginTestDescriptor) + waitForDiagnostics, (@?=)) import Text.Regex.TDFA ((=~)) main :: IO () From 4ef3904cbbc2094e4f29ed461c8aa12ac7d51a3b Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 17 Jun 2025 22:30:27 -0400 Subject: [PATCH 09/10] REWORDME: Make maybes into traversals --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 70 +++++++++++-------- 1 file changed, 42 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 65002641d4..7222e942a2 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 @@ -52,6 +52,7 @@ import Ide.Types (Config, HandlerM, import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Text.Regex.TDFA ((=~)) +import Control.Applicative (liftA) data Log = LogErrInfoCtxt ErrInfo @@ -137,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 Development.IDE.Warning (LogErrInfoCtxt errInfo) @@ -160,35 +162,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 @@ -204,8 +219,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 ce74f1217b5a42777e302c3606b6478bdf7a16e8 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 17 Jun 2025 22:50:11 -0400 Subject: [PATCH 10/10] Add some comments --- .../src/Ide/Plugin/ChangeTypeSignature.hs | 7 +++++-- 1 file changed, 5 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 7222e942a2..5fd7ee9463 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 @@ -135,6 +135,7 @@ diagnosticToChangeSig -> 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 @@ -146,15 +147,17 @@ diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do pure (showType expectedType, showType actualType, errInfo) - logWith recorder Development.IDE.Warning (LogErrInfoCtxt 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 Development.IDE.Warning (LogFindSigLocFailure declName) + logWith recorder Debug (LogFindSigLocFailure declName) hoistMaybe Nothing pure ChangeSignature{..}