Implement renaming import aliases

haskell-language-server.cabal

@@ -595,6 +595,7 @@ library hls-rename-plugin
     buildable: False
   exposed-modules:
     Ide.Plugin.Rename
+    Ide.Plugin.Rename.ImportAlias
     Ide.Plugin.Rename.ModuleName
   hs-source-dirs:   plugins/hls-rename-plugin/src
   build-depends:
@@ -608,6 +609,7 @@ library hls-rename-plugin
     , hls-plugin-api        == 2.13.0.0
     , haskell-language-server:hls-refactor-plugin
     , lens
+    , lsp
     , lsp-types
     , mtl
     , mod

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

@@ -53,12 +53,14 @@ import           Ide.Logger                            (Pretty (..),
                                                         cmapWithPrio)
 import           Ide.Plugin.Error
 import           Ide.Plugin.Properties
+import qualified Ide.Plugin.Rename.ImportAlias         as ImportAlias
 import qualified Ide.Plugin.Rename.ModuleName          as ModuleName
 import           Ide.PluginUtils
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens            as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
+import qualified Language.LSP.VFS                      as VFS
 
 instance Hashable (Mod a) where hash n = hash (unMod n)
 
@@ -88,28 +90,71 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor exactPrintRecorder $
         moduleNameRecorder = cmapWithPrio LogModuleName recorder
 
 prepareRenameProvider :: PluginMethodHandler IdeState Method_TextDocumentPrepareRename
-prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifier uri) pos _progressToken) = do
+prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifier uri) lspPos _progressToken) = do
     nfp <- getNormalizedFilePathE uri
-    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" (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.
-    pure $ case spansWithNamesUnderCursor of
-        [] -> InR Null
-        srcSpan : _ -> InL $ PrepareRenameResult $ InL (realSrcSpanToRange srcSpan)
+    codePointPos <- getCodePointPosition state nfp lspPos
+    maybeParsed <- ImportAlias.getParsedModuleStale state nfp
+    case maybeParsed of
+        Nothing -> throwError $ PluginInternalError
+            "The module hasn’t yet been parsed. Please wait for indexing to complete and try again."
+        Just parsed -> do
+            let hsModule = unLoc $ pm_parsed_source parsed
+                exports = hsmodExports hsModule
+                imports = hsmodImports hsModule
+                hsDecls = hsmodDecls hsModule
+            maybeAlias <- ImportAlias.resolveAliasAtPos
+                getNamesAtPos state nfp lspPos codePointPos exports imports hsDecls
+            case maybeAlias of
+                Just (lspRange, _importAlias) ->
+                    pure $ InL $ PrepareRenameResult $ InL $ lspRange
+                Nothing -> do
+                    HAR{hieAst} <- handleGetHieAst state nfp
+                    let spansWithNamesUnderCursor =
+                            [ srcSpan
+                            | (names, srcSpan) <- getNamesSpansAtPoint' hieAst lspPos
+                            , 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" (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.
+                    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
+renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) lspPos newNameText) = do
     nfp <- getNormalizedFilePathE uri
+    codePointPos <- getCodePointPosition state nfp lspPos
+    maybeParsed <- ImportAlias.getParsedModuleStale state nfp
+    case maybeParsed of
+        Nothing -> throwError $ PluginInternalError
+            "The module hasn’t yet been parsed. Please wait for indexing to complete and try again."
+        Just parsed -> do
+            let hsModule = unLoc $ pm_parsed_source parsed
+                exports = hsmodExports hsModule
+                imports = hsmodImports hsModule
+                hsDecls = hsmodDecls hsModule
+            maybeAlias <- ImportAlias.resolveAliasAtPos
+                getNamesAtPos state nfp lspPos codePointPos exports imports hsDecls
+            case maybeAlias of
+                Just (_lspRange, importAlias) -> ImportAlias.aliasBasedRename
+                    state nfp uri importAlias exports hsDecls newNameText
+                Nothing ->
+                    nameBasedRename state pluginId nfp lspPos newNameText
+
+-- | Name-based rename: the original rename logic.
+nameBasedRename ::
+    IdeState ->
+    PluginId ->
+    NormalizedFilePath ->
+    Position ->
+    T.Text ->
+    ExceptT PluginError (HandlerM config) (MessageResult Method_TextDocumentRename)
+nameBasedRename state pluginId nfp pos newNameText = do
     directOldNames <- getNamesAtPos state nfp pos
     directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames
 
@@ -188,17 +233,14 @@ replaceRefs ::
     HashSet Location ->
     ParsedSource ->
     ParsedSource
-replaceRefs newName refs = everywhere $
-    -- there has to be a better way...
-    mkT (replaceLoc @AnnListItem) `extT`
-    -- replaceLoc @AnnList `extT` -- not needed
-    -- replaceLoc @AnnParen `extT` -- not needed
-    -- replaceLoc @AnnPragma `extT` -- not needed
-    -- replaceLoc @AnnContext `extT` -- not needed
-    -- replaceLoc @NoEpAnns `extT` -- not needed
-    replaceLoc @NameAnn
+replaceRefs newName refs = everywhere (mkT replaceLoc)
     where
-        replaceLoc :: forall an. LocatedAn an RdrName -> LocatedAn an RdrName
+        -- See Note [XRec and SrcSpans in the AST] in Language.Haskell.Syntax.Extension
+        -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation
+        -- GHC recommends using 'XRec' (available since 9.4.8 or earlier) to
+        -- get the right annotation type for a given target type.
+        -- XRec (GhcPass 'Parsed) RdrName = GenLocated (Anno RdrName) RdrName
+        replaceLoc :: XRec (GhcPass 'Parsed) RdrName -> XRec (GhcPass 'Parsed) RdrName
         replaceLoc (L srcSpan oldRdrName)
             | isRef (locA srcSpan) = L srcSpan $ replace oldRdrName
         replaceLoc lOldRdrName = lOldRdrName
@@ -226,6 +268,7 @@ refsAtName state nfp name = do
         Nothing -> pure []
         Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb ->
             -- See Note [Generated references]
+            -- REVIEW: Is this filter supposed to keep or remove generated references?
             filter (\(refRow HieDb.:. _) -> refIsGenerated refRow) <$>
             findReferences
                 hieDb
@@ -245,6 +288,28 @@ nameLocs name (HAR _ _ rm _ _) =
 ---------------------------------------------------------------------------------------------------
 -- Util
 
+-- | Convert an LSP position (based on UTF-16 code units) to a position based on
+-- whole Unicode code points.
+getCodePointPosition ::
+    MonadIO m =>
+    IdeState ->
+    NormalizedFilePath ->
+    Position ->
+    ExceptT PluginError m VFS.CodePointPosition
+getCodePointPosition state nfp pos = do
+    virtualFile <- runActionE "rename.getVirtualFile" state
+        $ handleMaybeM (PluginInternalError
+            ("Virtual file not found: " <> T.pack (show nfp)))
+        $ getVirtualFile nfp
+    case VFS.positionToCodePointPosition virtualFile pos of
+        Nothing -> throwError $ PluginInvalidParams
+            "The cursor position is inside a Unicode surrogate pair."
+        Just codePointPosition -> pure codePointPosition
+
+-- FIXME: 'getNamesAtPos' passes the LSP 'Position' directly to 'pointCommand',
+-- which treats '_character' as a code-point column. This is incorrect for
+-- files with supplementary-plane Unicode characters before the cursor.
+-- Fixing it requires changes to 'pointCommand' in ghcide, not here.
 getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name]
 getNamesAtPos state nfp pos = do
     HAR{hieAst} <- handleGetHieAst state nfp
@@ -289,11 +354,13 @@ 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'
+-- FIXME: The use of 'pointCommand' is problematic. See 'getNamesAtPos' above.
 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.
+-- FIXME: The use of 'pointCommand' is problematic. See 'getNamesAtPos' above.
 getNamesSpansAtPoint' :: HieASTs a -> Position -> [([Name], RealSrcSpan)]
 getNamesSpansAtPoint' hf pos =
   pointCommand hf pos $