Improve prepareRename responses

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

@@ -90,16 +90,22 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor exactPrintRecorder $
 prepareRenameProvider :: PluginMethodHandler IdeState Method_TextDocumentPrepareRename
 prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifier uri) pos _progressToken) = do
     nfp <- getNormalizedFilePathE uri
-    namesUnderCursor <- getNamesAtPos state nfp pos
+    HAR{hieAst} <- handleGetHieAst state nfp
+    let spansWithNamesUnderCursor =
+            [ srcSpan
+            | (names, srcSpan) <- getNamesSpansAtPoint' hieAst pos
+            , not (null names)]
     -- 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".
+    -- to mean "there is no Name at given position" (in which case
+    -- `spansWithNamesUnderCursor` would be empty).
     --
     -- 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 $ PrepareRenameDefaultBehavior renameValid
+    pure $ case spansWithNamesUnderCursor of
+        [] -> InR Null
+        srcSpan : _ -> InL $ PrepareRenameResult $ InL (realSrcSpanToRange srcSpan)
 
 renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename
 renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do
@@ -287,6 +293,12 @@ getNamesAtPoint' :: HieASTs a -> Position -> [Name]
 getNamesAtPoint' hf pos =
   concat $ pointCommand hf pos (rights . M.keys . getNodeIds)
 
+-- | A variant of `getNamesAtPoint'` that also returns source spans.
+getNamesSpansAtPoint' :: HieASTs a -> Position -> [([Name], RealSrcSpan)]
+getNamesSpansAtPoint' hf pos =
+  pointCommand hf pos $
+    \astNode -> (rights . M.keys . getNodeIds $ astNode, nodeSpan astNode)
+
 locToUri :: Location -> Uri
 locToUri (Location uri _) = uri
 

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

@@ -4,14 +4,15 @@
 
 module Main (main) where
 
-import           Control.Lens               ((^.))
-import           Data.Aeson
-import           Data.Functor               (void)
-import qualified Data.Map                   as M
-import           Data.Text                  (Text, pack)
+import           Control.Lens                ((^.))
+import           Data.Aeson                  (KeyValue ((.=)))
+import           Data.Functor                (void)
+import qualified Data.Map                    as M
+import           Data.Text                   (Text, pack)
 import           Ide.Plugin.Config
-import qualified Ide.Plugin.Rename          as Rename
-import qualified Language.LSP.Protocol.Lens as L
+import qualified Ide.Plugin.Rename           as Rename
+import qualified Language.LSP.Protocol.Lens  as L
+import           Language.LSP.Protocol.Types (Null (Null))
 import           System.FilePath
 import           Test.Hls
 
@@ -23,10 +24,54 @@ renamePlugin = mkPluginTestDescriptor Rename.descriptor "rename"
 
 tests :: TestTree
 tests = testGroup "Rename"
-    [ renameTests
+    [ prepareRenameTests
+    , renameTests
     , moduleNameTests
     ]
 
+prepareRenameTests :: TestTree
+prepareRenameTests = testGroup "PrepareRename"
+    [ testCase "Module name (not yet renameable)" $ runRenameSession "" $ do
+        doc <- openDoc "PrepareRename.hs" "haskell"
+        void waitForBuildQueue
+        result <- prepareRename doc (Position 0 9)
+        liftIO $ result @?= InR Null
+
+    , testCase "Function name" $ runRenameSession "" $ do
+        doc <- openDoc "PrepareRename.hs" "haskell"
+        void waitForBuildQueue
+        result <- prepareRename doc (Position 8 1)
+        liftIO $ result @?=
+            InL (PrepareRenameResult (InL (Range (Position 8 0) (Position 8 3))))
+
+    , testCase "Imported function name" $ runRenameSession "" $ do
+        doc <- openDoc "PrepareRename.hs" "haskell"
+        void waitForBuildQueue
+        result <- prepareRename doc (Position 10 16)
+        liftIO $ result @?=
+            InL (PrepareRenameResult (InL (Range (Position 10 14) (Position 10 19))))
+
+    , testCase "Non-renameable position" $ runRenameSession "" $ do
+        doc <- openDoc "PrepareRename.hs" "haskell"
+        void waitForBuildQueue
+        result <- prepareRename doc (Position 6 23)
+        liftIO $ result @?= InR Null
+
+    , testCase "Operator" $ runRenameSession "" $ do
+        doc <- openDoc "PrepareRename.hs" "haskell"
+        void waitForBuildQueue
+        result <- prepareRename doc (Position 10 7)
+        liftIO $ result @?=
+            InL (PrepareRenameResult (InL (Range (Position 10 6) (Position 10 9))))
+
+    , testCase "Built-in operator" $ runRenameSession "" $ do
+        doc <- openDoc "PrepareRename.hs" "haskell"
+        void waitForBuildQueue
+        result <- prepareRename doc (Position 13 7)
+        liftIO $ result @?=
+            InL (PrepareRenameResult (InL (Range (Position 13 7) (Position 13 8))))
+    ]
+
 renameTests :: TestTree
 renameTests = testGroup "Identifier"
     [ goldenWithRename "Data constructor" "DataConstructor" $ \doc ->
@@ -175,6 +220,16 @@ goldenWithRename title path act =
     goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] })
        renamePlugin title testDataDir path "expected" "hs" act
 
+-- NOTE: This should eventually be moved upstream to lsp-test (see
+-- https://github.com/haskell/lsp/issues/636).
+prepareRename :: TextDocumentIdentifier -> Position -> Session (PrepareRenameResult |? Null)
+prepareRename doc pos = do
+  let params = PrepareRenameParams doc pos Nothing
+  rsp <- request SMethod_TextDocumentPrepareRename params
+  case rsp ^. L.result of
+    Left rspError -> liftIO $ assertFailure $ "prepareRename failed: " <> show rspError
+    Right rspResult -> pure rspResult
+
 renameExpectError :: TResponseError Method_TextDocumentRename -> TextDocumentIdentifier -> Position -> Text -> Session ()
 renameExpectError expectedError doc pos newName = do
   let params = RenameParams Nothing doc pos newName

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

@@ -0,0 +1,14 @@
+module PrepareRename where
+
+import qualified Foo as F
+
+main :: IO Int
+main = do
+    x <- return $ foo 42
+    return (foo x)
+foo, bar :: Int -> Int
+foo x = x + 1
+bar = (+) 1 . F.foo . foo
+
+baz :: a -> [a]
+baz = (: [])