Improve handling of nonsense rename attempts

haskell-language-server.cabal

@@ -508,6 +508,7 @@ library hls-rename-plugin
     , mtl
     , mod
     , syb
+    , row-types
     , text
     , transformers
     , unordered-containers
@@ -526,6 +527,9 @@ test-suite hls-rename-plugin-tests
     , hls-plugin-api
     , haskell-language-server:hls-rename-plugin
     , hls-test-utils             == 2.7.0.0
+    , lens
+    , lsp-types
+    , text
 
 -----------------------------
 -- retrie plugin

hls-plugin-api/src/Ide/Types.hs

@@ -475,6 +475,9 @@ instance PluginMethod Request Method_CodeLensResolve where
 instance PluginMethod Request Method_TextDocumentRename where
   handlesRequest = pluginEnabledWithFeature plcRenameOn
 
+instance PluginMethod Request Method_TextDocumentPrepareRename where
+  handlesRequest = pluginEnabledWithFeature plcRenameOn
+
 instance PluginMethod Request Method_TextDocumentHover where
   handlesRequest = pluginEnabledWithFeature plcHoverOn
 
@@ -599,7 +602,7 @@ class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer
 ---
 instance PluginRequestMethod Method_TextDocumentCodeAction where
   combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps =
-      InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps
+      InL $ fmap compat $ concatMap (filter wasRequested) $ mapMaybe nullToMaybe $ toList resps
     where
       compat :: (Command |? CodeAction) -> (Command |? CodeAction)
       compat x@(InL _) = x
@@ -657,6 +660,10 @@ instance PluginRequestMethod Method_CodeLensResolve where
 
 instance PluginRequestMethod Method_TextDocumentRename where
 
+instance PluginRequestMethod Method_TextDocumentPrepareRename where
+    -- TODO more intelligent combining?
+    combineResponses _ _ _ _ (x :| _) = x
+
 instance PluginRequestMethod Method_TextDocumentHover where
   combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) =
     if null hs

plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs

@@ -25,6 +25,7 @@ import           Data.List.NonEmpty                    (NonEmpty ((:|)),
 import qualified Data.Map                              as M
 import           Data.Maybe
 import           Data.Mod.Word
+import           Data.Row
 import qualified Data.Set                              as S
 import qualified Data.Text                             as T
 import           Development.IDE                       (Recorder, WithPriority,
@@ -57,43 +58,66 @@ import           Language.LSP.Server
 instance Hashable (Mod a) where hash n = hash (unMod n)
 
 descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState
-descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor pluginId "Provides renaming of Haskell identifiers")
-    { pluginHandlers = mkPluginHandler SMethod_TextDocumentRename renameProvider
-    , pluginConfigDescriptor = defaultConfigDescriptor
-        { configCustomConfig = mkCustomConfig properties }
-    }
+descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $
+    (defaultPluginDescriptor pluginId "Provides renaming of Haskell identifiers")
+        { pluginHandlers = mconcat
+              [ mkPluginHandler SMethod_TextDocumentRename renameProvider
+              , mkPluginHandler SMethod_TextDocumentPrepareRename prepareRenameProvider
+              ]
+        , pluginConfigDescriptor = defaultConfigDescriptor
+            { configCustomConfig = mkCustomConfig properties }
+        }
+
+prepareRenameProvider :: PluginMethodHandler IdeState Method_TextDocumentPrepareRename
+prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifier uri) pos _progressToken) = do
+    nfp <- getNormalizedFilePathE uri
+    namesUnderCursor <- getNamesAtPos state nfp pos
+    -- When this handler says that rename is invalid, VSCode shows "The element can't be renamed"
+    -- and doesn't even allow you to create full rename request.
+    -- This handler deliberately approximates "things that definitely can't be renamed"
+    -- to mean "there is no Name at given position".
+    --
+    -- In particular it allows some cases through (e.g. cross-module renames),
+    -- so that the full rename handler can give more informative error about them.
+    let renameValid = not $ null namesUnderCursor
+    pure $ InL $ PrepareRenameResult $ InR $ InR $ #defaultBehavior .== renameValid
 
 renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename
 renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do
-        nfp <- getNormalizedFilePathE uri
-        directOldNames <- getNamesAtPos state nfp pos
-        directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames
-
-        {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have
-           indirect references through punned names. To find the transitive closure, we do a pass of
-           the direct references to find the references for any punned names.
-           See the `IndirectPuns` test for an example. -}
-        indirectOldNames <- concat . filter ((>1) . length) <$>
-            mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs
-        let oldNames = filter matchesDirect indirectOldNames ++ directOldNames
-            matchesDirect n = occNameFS (nameOccName n) `elem` directFS
-              where
-                directFS = map (occNameFS. nameOccName) directOldNames
-        refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames
-
-        -- Validate rename
-        crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties
-        unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames
-        when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax"
-
-        -- Perform rename
-        let newName = mkTcOcc $ T.unpack newNameText
-            filesRefs = collectWith locToUri refs
-            getFileEdit (uri, locations) = do
-              verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri)
-              getSrcEdit state verTxtDocId (replaceRefs newName locations)
-        fileEdits <- mapM getFileEdit filesRefs
-        pure $ InL $ fold fileEdits
+    nfp <- getNormalizedFilePathE uri
+    directOldNames <- getNamesAtPos state nfp pos
+    directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames
+
+    {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have
+        indirect references through punned names. To find the transitive closure, we do a pass of
+        the direct references to find the references for any punned names.
+        See the `IndirectPuns` test for an example. -}
+    indirectOldNames <- concat . filter ((>1) . length) <$>
+        mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs
+    let oldNames = filter matchesDirect indirectOldNames ++ directOldNames
+           where
+             matchesDirect n = occNameFS (nameOccName n) `elem` directFS
+             directFS = map (occNameFS . nameOccName) directOldNames
+
+    case oldNames of
+        -- There were no Names at given position (e.g. rename triggered within a comment or on a keyword)
+        [] -> throwError $ PluginInvalidParams "No symbol to rename at given position"
+        _  -> do
+            refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames
+
+            -- Validate rename
+            crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties
+            unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames
+            when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax"
+
+            -- Perform rename
+            let newName = mkTcOcc $ T.unpack newNameText
+                filesRefs = collectWith locToUri refs
+                getFileEdit (uri, locations) = do
+                    verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri)
+                    getSrcEdit state verTxtDocId (replaceRefs newName locations)
+            fileEdits <- mapM getFileEdit filesRefs
+            pure $ InL $ fold fileEdits
 
 -- | Limit renaming across modules.
 failWhenImportOrExport ::

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

@@ -2,10 +2,13 @@
 
 module Main (main) where
 
+import           Control.Lens               ((^.))
 import           Data.Aeson
-import qualified Data.Map          as M
+import qualified Data.Map                   as M
+import           Data.Text                  (Text)
 import           Ide.Plugin.Config
-import qualified Ide.Plugin.Rename as Rename
+import qualified Ide.Plugin.Rename          as Rename
+import qualified Language.LSP.Protocol.Lens as L
 import           System.FilePath
 import           Test.Hls
 
@@ -64,11 +67,26 @@ tests = testGroup "Rename"
         rename doc (Position 2 17) "BinaryTree"
     , goldenWithRename "Type variable" "TypeVariable" $ \doc ->
         rename doc (Position 0 13) "b"
+    , goldenWithRename "Rename within comment" "Comment" $ \doc -> do
+        let expectedError = ResponseError
+                (InR ErrorCodes_InvalidParams)
+                "rename: Invalid Params: No symbol to rename at given position"
+                Nothing
+        renameExpectError expectedError doc (Position 0 10) "ImpossibleRename"
     ]
 
 goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
 goldenWithRename title path act =
-    goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act
+    goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] })
+       renamePlugin title testDataDir path "expected" "hs" act
+
+renameExpectError :: ResponseError -> TextDocumentIdentifier -> Position -> Text -> Session ()
+renameExpectError expectedError doc pos newName = do
+  let params = RenameParams Nothing doc pos newName
+  rsp <- request SMethod_TextDocumentRename params
+  case rsp ^. L.result of
+    Right _ -> liftIO $ assertFailure $ "Was expecting " <> show expectedError <> ", got success"
+    Left actualError -> liftIO $ assertEqual "ResponseError" expectedError actualError
 
 testDataDir :: FilePath
 testDataDir = "plugins" </> "hls-rename-plugin" </> "test" </> "testdata"

plugins/hls-rename-plugin/test/testdata/Comment.expected.hs

@@ -0,0 +1 @@
+{- IShouldNotBeRenaemable -}

plugins/hls-rename-plugin/test/testdata/Comment.hs

@@ -0,0 +1 @@
+{- IShouldNotBeRenaemable -}