Rename only if the current module compiles (#3799) (#3848)

* Rename only if the current module compiles (#3799)

Prefer `useE` over `useWithStaleE`

* Add a rename test that tests for compilation errors

Author: sgillespie

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)