Rename only if the current module compiles (#3799)

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
 
 -----------------------------

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,26 +209,29 @@ 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)
 
 ---------------------------------------------------------------------------------------------------
 -- Util
 
 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
 

plugins/hls-rename-plugin/test/Main.hs

@@ -1,11 +1,13 @@
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 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)