From da006bde3b81504bbcebc6b00a1bc06107fda900 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 16 Oct 2023 22:19:18 -0400 Subject: [PATCH 1/2] Rename only if the current module compiles (#3799) Prefer `useE` over `useWithStaleE` --- .../src/Ide/Plugin/Rename.hs | 29 +++++++++++-------- 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 757ae5fd26..322538503b 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -14,7 +14,7 @@ import Control.Monad import Control.Monad.Except (ExceptT, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) -import Data.Bifunctor (first) +import Data.Either (rights) import Data.Foldable (fold) import Data.Generics import Data.Hashable @@ -31,14 +31,11 @@ import qualified Data.Text as T import Development.IDE (Recorder, WithPriority, usePropertyAction) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.ExactPrint -import Development.IDE.GHC.Compat.Parser -import Development.IDE.GHC.Compat.Units import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import qualified Development.IDE.GHC.ExactPrint as E @@ -212,9 +209,9 @@ refsAtName state nfp name = do ) pure $ nameLocs name ast ++ dbRefs -nameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location] -nameLocs name (HAR _ _ rm _ _, pm) = - concatMap (mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst)) +nameLocs :: Name -> HieAstResult -> [Location] +nameLocs name (HAR _ _ rm _ _) = + concatMap (map (realSrcSpanToLocation . fst)) (M.lookup (Right name) rm) --------------------------------------------------------------------------------------------------- @@ -222,16 +219,19 @@ nameLocs name (HAR _ _ rm _ _, pm) = getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name] getNamesAtPos state nfp pos = do - (HAR{hieAst}, pm) <- handleGetHieAst state nfp - pure $ getNamesAtPoint hieAst pos pm + HAR{hieAst} <- handleGetHieAst state nfp + pure $ getNamesAtPoint' hieAst pos handleGetHieAst :: MonadIO m => IdeState -> NormalizedFilePath -> - ExceptT PluginError m (HieAstResult, PositionMapping) + ExceptT PluginError m HieAstResult handleGetHieAst state nfp = - fmap (first removeGenerated) $ runActionE "Rename.GetHieAst" state $ useWithStaleE GetHieAst nfp + -- We explicitly do not want to allow a stale version here - we only want to rename if + -- the module compiles, otherwise we can't guarantee that we'll rename everything, + -- which is bad (see https://github.com/haskell/haskell-language-server/issues/3799) + fmap removeGenerated $ runActionE "Rename.GetHieAst" state $ useE GetHieAst nfp -- | We don't want to rename in code generated by GHC as this gives false positives. -- So we restrict the HIE file to remove all the generated code. @@ -246,6 +246,11 @@ removeGenerated HAR{..} = HAR{hieAst = go hieAst,..} collectWith :: (Hashable a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupWith f . HS.toList +-- | A variant 'getNamesAtPoint' that does not expect a 'PositionMapping' +getNamesAtPoint' :: HieASTs a -> Position -> [Name] +getNamesAtPoint' hf pos = + concat $ pointCommand hf pos (rights . M.keys . getNodeIds) + locToUri :: Location -> Uri locToUri (Location uri _) = uri From dd5feec3d7c849aebf2f72e8264c7d48da29294d Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Sat, 21 Oct 2023 14:14:21 -0400 Subject: [PATCH 2/2] Add a rename test that tests for compilation errors --- haskell-language-server.cabal | 1 + plugins/hls-rename-plugin/test/Main.hs | 56 +++++++++++++++++++++++++- 2 files changed, 56 insertions(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 759288f081..440b6aeaac 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -614,6 +614,7 @@ test-suite hls-rename-plugin-tests , hls-test-utils == 2.7.0.0 , lens , lsp-types + , row-types , text ----------------------------- diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 2ef53dfe25..9de40a3e22 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where @@ -5,7 +6,8 @@ module Main (main) where import Control.Lens ((^.)) import Data.Aeson import qualified Data.Map as M -import Data.Text (Text) +import Data.Row ((.+), (.==)) +import Data.Text (Text, pack) import Ide.Plugin.Config import qualified Ide.Plugin.Rename as Rename import qualified Language.LSP.Protocol.Lens as L @@ -73,6 +75,40 @@ tests = testGroup "Rename" "rename: Invalid Params: No symbol to rename at given position" Nothing renameExpectError expectedError doc (Position 0 10) "ImpossibleRename" + + , testCase "fails when module does not compile" $ runRenameSession "" $ do + doc <- openDoc "FunctionArgument.hs" "haskell" + expectNoMoreDiagnostics 3 doc "typecheck" + + -- Update the document so it doesn't compile + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 13) (Position 2 17) + .+ #rangeLength .== Nothing + .+ #text .== "A" + changeDoc doc [change] + diags@(tcDiag : _) <- waitForDiagnosticsFrom doc + + -- Make sure there's a typecheck error + liftIO $ do + length diags @?= 1 + tcDiag ^. L.range @?= Range (Position 2 13) (Position 2 14) + tcDiag ^. L.severity @?= Just DiagnosticSeverity_Error + tcDiag ^. L.source @?= Just "typecheck" + + -- Make sure renaming fails + renameErr <- expectRenameError doc (Position 3 0) "foo'" + liftIO $ do + renameErr ^. L.code @?= InL LSPErrorCodes_RequestFailed + renameErr ^. L.message @?= "rename: Rule Failed: GetHieAst" + + -- Update the document so it compiles + let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 13) (Position 2 14) + .+ #rangeLength .== Nothing + .+ #text .== "Int" + changeDoc doc [change'] + expectNoMoreDiagnostics 3 doc "typecheck" + + -- Make sure renaming succeeds + rename doc (Position 3 0) "foo'" ] goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree @@ -90,3 +126,21 @@ renameExpectError expectedError doc pos newName = do testDataDir :: FilePath testDataDir = "plugins" "hls-rename-plugin" "test" "testdata" + +-- | Attempts to renames the term at the specified position, expecting a failure +expectRenameError :: + TextDocumentIdentifier -> + Position -> + String -> + Session ResponseError +expectRenameError doc pos newName = do + let params = RenameParams Nothing doc pos (pack newName) + rsp <- request SMethod_TextDocumentRename params + case rsp ^. L.result of + Left err -> pure err + Right _ -> liftIO $ assertFailure $ + "Got unexpected successful rename response for " <> show (doc ^. L.uri) + +runRenameSession :: FilePath -> Session a -> IO a +runRenameSession subdir = failIfSessionTimeout + . runSessionWithServerAndCaps def renamePlugin codeActionNoResolveCaps (testDataDir subdir)