diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index b140955294..a65398308d 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c6fd8741a3..bd8f134716 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/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 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index c25da1bd46..757ae5fd26 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/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 :: diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index ffedf9c0e0..2ef53dfe25 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-rename-plugin/test/testdata/Comment.expected.hs b/plugins/hls-rename-plugin/test/testdata/Comment.expected.hs new file mode 100644 index 0000000000..d58fd349a8 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Comment.expected.hs @@ -0,0 +1 @@ +{- IShouldNotBeRenaemable -} diff --git a/plugins/hls-rename-plugin/test/testdata/Comment.hs b/plugins/hls-rename-plugin/test/testdata/Comment.hs new file mode 100644 index 0000000000..d58fd349a8 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Comment.hs @@ -0,0 +1 @@ +{- IShouldNotBeRenaemable -}