diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 514ee6f0cb..12706e18d6 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index d22e6b6913..25c8bc6c48 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/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 + +-- | Logic for renaming all occurrences of a 'Name'. +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 $ diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ImportAlias.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ImportAlias.hs new file mode 100644 index 0000000000..aacbcd5b77 --- /dev/null +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ImportAlias.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +{-| Logic for renaming qualified import aliases. + +The basic approach is this: + +1. Get the parsed AST and see if there is an import alias at the cursor. +2. Check whether multiple modules are imported using the same alias. +3. Rename entities throughout the AST: + * If only one module uses the alias, perform renaming using 'RdrName' and + the parsed AST. + * If multiple modules use the alias, perform alias resolution and renaming + using 'GlobalRdrEnv' and the typechecked AST. + +The common case, with each alias corresponding to one module, should be very +fast, even when the user renames multiple aliases in quick succession. + +NOTE: This module avoids manipulating LSP 'Position' and 'Range' values +directly, because by default these are in UTF-16 code units, while GHC source +spans are in Unicode code points. Instead, this module uses +'VFS.CodePointPosition' and 'VFS.CodePointRange'. +-} +module Ide.Plugin.Rename.ImportAlias + ( getParsedModuleStale + , resolveAliasAtPos + , aliasBasedRename + ) where + +import Control.Lens ((&), (+~), (.~), (^.)) +import Control.Monad (guard, when) +import Control.Monad.Except (ExceptT, + MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Containers.ListUtils (nubOrd) +import Data.Generics +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Development.IDE (realSrcSpanToCodePointRange) +import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service hiding (Log) +import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.GHC.Compat hiding (importDecl) +import Development.IDE.GHC.Compat.Util (stringToStringBuffer) +import GHC.Data.FastString (lengthFS) +import qualified GHC.Utils.Error as GHC +import Ide.Plugin.Error +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Position, Range) +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.VFS (codePointRangeToRange) +import qualified Language.LSP.VFS as VFS + +-- | The module name, alias name, declaration text range, and sharing status +-- for an import alias. +-- For example, @import Data.List as L@ corresponds to @ImportAlias "Data.List" +-- "L" @. +data ImportAlias = ImportAlias + { aliasModuleName :: ModuleName + , aliasName :: ModuleName + , aliasDeclRange :: VFS.CodePointRange + , aliasIsShared :: Bool + } + deriving (Eq, Ord) + +-- | Fetch the parsed module for a file, accepting a stale result. +-- Returns @Nothing@ if the file has never been indexed. +getParsedModuleStale :: + MonadIO m => + IdeState -> + NormalizedFilePath -> + m (Maybe ParsedModule) +getParsedModuleStale state nfp = + liftIO $ fmap fst <$> + runAction "rename.getParsedModuleStale" state + (useWithStale GetParsedModule nfp) + +-- | Return the 'ImportAlias' and corresponding text range at the cursor. The +-- cursor may be on the alias token in an import declaration or on a qualifier +-- at a use site. If multiple imports share the same alias, falls back to the +-- typechecked module's 'GlobalRdrEnv' to disambiguate. +-- Returns @Nothing@ if the cursor is not on an import alias. +-- HACK: The first argument is `Rename.getNamesAtPos`, parameterized to avoid a +-- circular dependency. +resolveAliasAtPos :: + MonadIO m => + (IdeState -> NormalizedFilePath -> LSP.Position -> ExceptT PluginError m [Name]) -> + IdeState -> + NormalizedFilePath -> + LSP.Position -> + VFS.CodePointPosition -> + Maybe (XRec GhcPs [LIE GhcPs]) -> + [LImportDecl GhcPs] -> + [LHsDecl GhcPs] -> + ExceptT PluginError m (Maybe (LSP.Range, ImportAlias)) +resolveAliasAtPos getNamesAtPosFn state nfp lspPos pos exports imports hsDecls = do + virtualFile <- runActionE "rename.getVirtualFile" state + $ handleMaybeM (PluginInternalError + ("Virtual file not found: " <> T.pack (show nfp))) + $ getVirtualFile nfp + let toLSPRange (range, alias) = case codePointRangeToRange virtualFile range of + Nothing -> Nothing + Just lspRange -> Just (lspRange, alias) + case findAliasDeclAtPos pos imports of + Just alias -> pure $ toLSPRange (aliasDeclRange alias, alias) + Nothing -> case findAliasUseAtPos pos exports imports hsDecls of + Nothing -> pure Nothing + Just (_, []) -> pure Nothing + Just (range, [alias]) -> pure $ toLSPRange (range, alias) + Just (range, candidates) -> do + tcModule <- runActionE "rename.resolveAlias" state $ useE TypeCheck nfp + namesAtPos <- getNamesAtPosFn state nfp lspPos + case disambiguateAliasUse tcModule namesAtPos candidates of + [] -> pure Nothing + [alias] -> pure $ toLSPRange (range, alias) + aliases@(alias1 : alias2 : _) -> throwError $ PluginInvalidParams $ + let aliasCount = T.pack (show (length aliases)) + aliasText = moduleNameText (aliasName alias1) + module1 = moduleNameText (aliasModuleName alias1) + module2 = moduleNameText (aliasModuleName alias2) + in "Alias " <> quote aliasText + <> " is ambiguous (matching " <> aliasCount + <> " imports, including " <> quote module1 + <> " and " <> quote module2 + <> "). Try renaming " <> quote aliasText + <> " in one of these import declarations directly." + +-- | Build a 'WorkspaceEdit' renaming an import alias and all its use sites. +aliasBasedRename :: + MonadIO m => + IdeState -> + NormalizedFilePath -> + Uri -> + ImportAlias -> + Maybe (XRec GhcPs [LIE GhcPs]) -> + [LHsDecl GhcPs] -> + T.Text -> + ExceptT PluginError m (MessageResult Method_TextDocumentRename) +aliasBasedRename state nfp uri importAlias exports hsDecls newNameText = do + when (not (isValidAlias newNameText)) $ + throwError (PluginInvalidParams (quote newNameText <> " is an invalid import alias.")) + let ImportAlias{aliasDeclRange, aliasIsShared} = importAlias + virtualFile <- runActionE "rename.getVirtualFile" state + $ handleMaybeM (PluginInternalError + ("Virtual file not found: " <> T.pack (show nfp))) + $ getVirtualFile nfp + useSiteRanges <- + if aliasIsShared + then do + tcModule <- runActionE "rename.sharedAliasRanges" state $ useE TypeCheck nfp + pure $ aliasUseSiteRangesDisambiguated tcModule importAlias exports hsDecls + else + pure $ aliasUseSiteRanges importAlias exports hsDecls + declEdit <- handleMaybe (PluginInternalError "Alias declaration span is out of range") + $ rangeToTextEdit virtualFile newNameText aliasDeclRange + useEdits <- handleMaybe (PluginInternalError "A use site span is out of range") + $ traverse (rangeToTextEdit virtualFile newNameText) useSiteRanges + let allEdits = declEdit : useEdits + verTxtDocId <- liftIO $ runAction "rename.getVersionedTextDoc" state $ + getVersionedTextDoc (TextDocumentIdentifier uri) + let fileChanges = Just $ M.singleton (verTxtDocId ^. L.uri) allEdits + -- TODO: Replace 'Nothing' with meaningful details (`ChangeAnnotation`). + workspaceEdit = WorkspaceEdit fileChanges Nothing Nothing + pure $ InL workspaceEdit + +-- | Find the 'ImportAlias' if the cursor is on an import alias declaration, +-- such as @L@ in @import Data.List as L@. +findAliasDeclAtPos :: + VFS.CodePointPosition -> + [LImportDecl GhcPs] -> + Maybe ImportAlias +findAliasDeclAtPos pos imports = listToMaybe $ do + let allAliases = mapMaybe (fmap unLoc . ideclAs . unLoc) imports + importDecl <- map unLoc imports + Just locatedAlias <- [ideclAs importDecl] + RealSrcSpan aliasDeclSpan _ <- [getLoc locatedAlias] + let aliasDeclRange = realSrcSpanToCodePointRange aliasDeclSpan + guard (rangeContainsPositionInclusive aliasDeclRange pos) + let aliasModuleName = unLoc (ideclName importDecl) + aliasName = unLoc locatedAlias + aliasIsShared = case filter (== aliasName) allAliases of + [] -> False + [_] -> False + (_ : _ : _) -> True + [ImportAlias{aliasModuleName, aliasName, aliasDeclRange, aliasIsShared}] + +-- | Find the text range and matching 'ImportAlias' for the name qualifier at +-- the cursor, such as @L@ in @L.take@. +-- Returns multiple aliases if multiple modules share the same alias. +findAliasUseAtPos :: + VFS.CodePointPosition -> + Maybe (XRec GhcPs [LIE GhcPs]) -> + [LImportDecl GhcPs] -> + [LHsDecl GhcPs] -> + Maybe (VFS.CodePointRange, [ImportAlias]) +findAliasUseAtPos pos exports imports hsDecls = + let qualifiersAtPos = do + locatedRdrName <- locateRdrNames exports hsDecls + Qual qualifier _ <- [unLoc locatedRdrName] + RealSrcSpan qualifiedNameSpan _ <- [getLoc locatedRdrName] + let qualifiedNameRange = realSrcSpanToCodePointRange qualifiedNameSpan + guard (rangeContainsPositionInclusive qualifiedNameRange pos) + let qualifierLength = fromIntegral (moduleNameLength qualifier) + qualifierStart = qualifiedNameRange ^. VFS.start + qualifierRange = qualifiedNameRange + & VFS.end .~ (qualifierStart & VFS.character +~ qualifierLength) + guard (rangeContainsPositionInclusive qualifierRange pos) + [(qualifierRange, qualifier)] + in case qualifiersAtPos of + [] -> Nothing + (rangeAtPos, qualifierAtPos) : _ -> Just $ (,) rangeAtPos $ do + let allAliases = mapMaybe (fmap unLoc . ideclAs . unLoc) imports + importDecl <- map unLoc imports + Just locatedAlias <- [ideclAs importDecl] + let aliasName = unLoc locatedAlias + guard (aliasName == qualifierAtPos) + RealSrcSpan aliasDeclSpan _ <- [getLoc locatedAlias] + let aliasModuleName = unLoc (ideclName importDecl) + aliasDeclRange = realSrcSpanToCodePointRange aliasDeclSpan + aliasIsShared = length (filter (== aliasName) allAliases) > 1 + [ImportAlias{aliasModuleName, aliasName, aliasDeclRange, aliasIsShared}] + +-- | Collect the 'CodePointRange' of every qualified use of @importAlias@, such +-- as @L@ in @L.take@, @L.drop@, and so on. +aliasUseSiteRanges :: + ImportAlias -> + Maybe (XRec GhcPs [LIE GhcPs]) -> + [LHsDecl GhcPs] -> + [VFS.CodePointRange] +aliasUseSiteRanges importAlias exports hsDecls = nubOrd $ do + let ImportAlias{aliasName} = importAlias + aliasLength = fromIntegral (moduleNameLength aliasName) + locatedRdrName <- locateRdrNames exports hsDecls + Qual qualifier _ <- [unLoc locatedRdrName] + guard (qualifier == aliasName) + RealSrcSpan qualifiedNameSpan _ <- [getLoc locatedRdrName] + let qualifiedNameRange = realSrcSpanToCodePointRange qualifiedNameSpan + qualifierStart = qualifiedNameRange ^. VFS.start + qualifierRange = qualifiedNameRange + & VFS.end .~ (qualifierStart & VFS.character +~ aliasLength) + [qualifierRange] + +--------------------------------------------------------------------------------------------------- +-- Special case: Multiple imports use the same alias + +-- | Resolve an ambiguous name qualifier by consulting the typechecked module's +-- 'GlobalRdrEnv' (or GRE). Used when multiple imports share the same alias. The +-- caller is responsible for providing the names at the cursor. +-- Returns multiple results if multiple modules export the same name (such as +-- @L.view@ with both @Control.Lens as L@ and @Control.Lens.Getter as L@). +disambiguateAliasUse :: + TcModuleResult -> + [Name] -> + [ImportAlias] -> + [ImportAlias] +disambiguateAliasUse tcModule namesAtPos candidates = nubOrd $ do + let rdrEnv = tcg_rdr_env (tmrTypechecked tcModule) + name <- namesAtPos + nameGREElement <- maybeToList (lookupGRE_Name rdrEnv name) + importSpec <- gre_imp nameGREElement + candidate@ImportAlias{aliasModuleName} <- candidates + guard (importSpecModule importSpec == aliasModuleName) + [candidate] + +-- | A variant of 'aliasUseSiteRanges' that resolves name qualifiers into full +-- module names and only selects those matching the module of @importAlias@. +-- Used when multiple imports share the same alias. +aliasUseSiteRangesDisambiguated :: + TcModuleResult -> + ImportAlias -> + Maybe (XRec GhcPs [LIE GhcPs]) -> + [LHsDecl GhcPs] -> + [VFS.CodePointRange] +aliasUseSiteRangesDisambiguated tcModule importAlias exports hsDecls = nubOrd $ do + let rdrEnv = tcg_rdr_env (tmrTypechecked tcModule) + ImportAlias{aliasModuleName, aliasName} = importAlias + aliasLength = fromIntegral (moduleNameLength aliasName) + locatedRdrName <- locateRdrNames exports hsDecls + rdrName@(Qual qualifier name) <- [unLoc locatedRdrName] + guard (qualifier == aliasName) + nameGREElement <- pickGREs rdrName $ lookupGlobalRdrEnv rdrEnv name + importSpec <- gre_imp nameGREElement + guard (importSpecModule importSpec == aliasModuleName) + RealSrcSpan qualifiedNameSpan _ <- [getLoc locatedRdrName] + let qualifiedNameRange = realSrcSpanToCodePointRange qualifiedNameSpan + qualifierStart = qualifiedNameRange ^. VFS.start + qualifierRange = qualifiedNameRange + & VFS.end .~ (qualifierStart & VFS.character +~ aliasLength) + [qualifierRange] + +--------------------------------------------------------------------------------------------------- +-- Utility functions + +-- | Locate 'RdrName' identifiers in the given export list and declarations. +locateRdrNames :: + Maybe (XRec GhcPs [LIE GhcPs]) -> + [LHsDecl GhcPs] -> + [XRec GhcPs RdrName] +locateRdrNames exports hsDecls = + listify (const True) exports ++ listify (const True) hsDecls + +-- | Check whether the given text is a valid alias. +-- Allows Unicode characters the same way GHC does. +-- REVIEW: If this looks good, we can add it to the existing name-based renaming +-- logic too (and move the CPP stuff to @Compat@). +isValidAlias :: T.Text -> Bool +isValidAlias t = case unP parseIdentifier parseState of + POk _ _ -> True + _ -> False + where + filename = "" + location = mkRealSrcLoc filename 1 1 + buffer = stringToStringBuffer (T.unpack (t <> ".f")) + parseState = initParserState minimalParserOpts buffer location + +minimalParserOpts :: ParserOpts +#if MIN_VERSION_ghc(9,13,0) +minimalParserOpts = mkParserOpts mempty emptyDiagOpts False False False False +#else +minimalParserOpts = mkParserOpts mempty emptyDiagOpts [] False False False False +#endif + +emptyDiagOpts :: GHC.DiagOpts +#if MIN_VERSION_ghc(9,7,0) +emptyDiagOpts = GHC.emptyDiagOpts +#else +emptyDiagOpts = GHC.DiagOpts mempty mempty False False Nothing defaultSDocContext +#endif + +-- >>> isValidAlias (T.pack "M") == True +-- >>> isValidAlias (T.pack "M.F") == True +-- >>> isValidAlias (T.pack "m") == False +-- >>> isValidAlias (T.pack "m.F") == False +-- >>> isValidAlias (T.pack "m.f") == False +-- >>> isValidAlias (T.pack "M.F hiding ()") == False +-- >>> isValidAlias (T.pack "Just . M") == False +-- >>> isValidAlias (T.pack "Dz") == True +-- >>> isValidAlias (T.pack "𝐹") == True +-- >>> isValidAlias (T.pack "𝑓") == False + +-- | Check whether a 'CodePointRange' contains a 'CodePointPosition' (inclusive +-- start, inclusive end). +-- NOTE: The use of inclusive end allows the user to place the cursor at the end +-- of an import alias and rename it. +rangeContainsPositionInclusive :: VFS.CodePointRange -> VFS.CodePointPosition -> Bool +rangeContainsPositionInclusive + (VFS.CodePointRange + (VFS.CodePointPosition startLine startColumn) + (VFS.CodePointPosition endLine endColumn)) + (VFS.CodePointPosition posLine posColumn) + = (posLine > startLine || (posLine == startLine && posColumn >= startColumn)) + && (posLine < endLine || (posLine == endLine && posColumn <= endColumn)) + +-- | Build a 'TextEdit' from a 'VFS.CodePointRange' and replacement text. +-- Returns @Nothing@ if the range is out of bounds in the VFS. +rangeToTextEdit :: VFS.VirtualFile -> T.Text -> VFS.CodePointRange -> Maybe TextEdit +rangeToTextEdit virtualFile newText range = TextEdit + <$> VFS.codePointRangeToRange virtualFile range + <*> Just newText + +-- | Return the length in Unicode code points for a 'ModuleName'. +moduleNameLength :: ModuleName -> Int +moduleNameLength = lengthFS . moduleNameFS + +-- | Return the module name as a 'Text' value. +moduleNameText :: ModuleName -> T.Text +moduleNameText = T.pack . moduleNameString + +-- | Surround the given text with curly single quotation marks (like GHC does in +-- compiler messages). +quote :: T.Text -> T.Text +quote t = "‘" <> t <> "’" diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 7974f8cc8c..454f26874c 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -8,7 +8,7 @@ import Control.Lens ((^.)) import Data.Aeson (KeyValue ((.=))) import Data.Functor (void) import qualified Data.Map as M -import Data.Text (Text, pack) +import Data.Text (Text, isInfixOf, pack, unpack) import Ide.Plugin.Config import qualified Ide.Plugin.Rename as Rename import qualified Language.LSP.Protocol.Lens as L @@ -37,6 +37,35 @@ prepareRenameTests = testGroup "PrepareRename" result <- prepareRename doc (Position 0 9) liftIO $ result @?= InR Null + , testCase "Import alias in declaration" $ runRenameSession "" $ do + doc <- openDoc "PrepareRename.hs" "haskell" + void waitForBuildQueue + let expected = InL (PrepareRenameResult (InL (Range (Position 2 24) (Position 2 25)))) + resultAtStart <- prepareRename doc (Position 2 24) + liftIO $ resultAtStart @?= expected + resultAtEnd <- prepareRename doc (Position 2 25) + liftIO $ resultAtEnd @?= expected + resultOutside <- prepareRename doc (Position 2 26) + liftIO $ resultOutside /= expected @? "Cursor is outside alias" + + , testCase "Import alias at use site" $ runRenameSession "" $ do + doc <- openDoc "PrepareRename.hs" "haskell" + void waitForBuildQueue + let expected = InL (PrepareRenameResult (InL (Range (Position 10 14) (Position 10 15)))) + resultAtStart <- prepareRename doc (Position 10 14) + liftIO $ resultAtStart @?= expected + resultAtEnd <- prepareRename doc (Position 10 15) + liftIO $ resultAtEnd @?= expected + resultOutside <- prepareRename doc (Position 10 16) + liftIO $ resultOutside /= expected @? "Cursor is outside qualifier" + + , testCase "Import alias in re-export" $ runRenameSession "" $ do + doc <- openDoc "PrepareRename.hs" "haskell" + void waitForBuildQueue + result <- prepareRename doc (Position 0 27) + liftIO $ result @?= + InL (PrepareRenameResult (InL (Range (Position 0 27) (Position 0 28)))) + , testCase "Function name" $ runRenameSession "" $ do doc <- openDoc "PrepareRename.hs" "haskell" void waitForBuildQueue @@ -93,6 +122,44 @@ renameTests = testGroup "Identifier" rename doc (Position 6 37) "Expr" , goldenWithRename "Hidden function" "HiddenFunction" $ \doc -> rename doc (Position 0 32) "quux" + , goldenWithRename "Import alias declaration" "ImportAlias" $ \doc -> + rename doc (Position 1 14) "G" + , goldenWithRename "Import alias at use site" "ImportAlias" $ \doc -> + rename doc (Position 5 6) "G" + , goldenWithRename "Import alias declaration (cursor at end)" "ImportAlias" $ \doc -> + rename doc (Position 1 18) "G" + , goldenWithRename "Import alias at use site (cursor at end)" "ImportAlias" $ \doc -> + rename doc (Position 5 10) "G" + , testCase "Import alias declaration (cursor at invalid Unicode position)" $ runRenameSession "" $ do + doc <- openDoc "ImportAlias.hs" "haskell" + expectNoMoreDiagnostics 3 doc "typecheck" + renameErr <- expectRenameError doc (Position 5 7) "G" + liftIO $ do + renameErr ^. L.code @?= InR ErrorCodes_InvalidParams + renameErr ^. L.message @?= "rename: Invalid Params: The cursor position is inside a Unicode surrogate pair." + , testCase "Import alias (invalid new alias)" $ runRenameSession "" $ do + doc <- openDoc "ImportAlias.hs" "haskell" + expectNoMoreDiagnostics 3 doc "typecheck" + renameErr <- expectRenameError doc (Position 5 6) "Just . G" + liftIO $ do + renameErr ^. L.code @?= InR ErrorCodes_InvalidParams + renameErr ^. L.message @?= "rename: Invalid Params: ‘Just . G’ is an invalid import alias." + , goldenWithRename "Import alias declaration (shared by unrelated imports)" "ImportAliasShared" $ \doc -> + rename doc (Position 3 31) "Maybe" + , goldenWithRename "Import alias at use site (shared by unrelated imports)" "ImportAliasShared" $ \doc -> + rename doc (Position 6 6) "Maybe" + , goldenWithRename "Import alias declaration (with re-exports)" "ImportAliasReexport" $ \doc -> do + rename doc (Position 1 18) "Reexport" + , testCase "Import alias at use site (ambiguous due to re-exports)" $ runRenameSession "" $ do + doc <- openDoc "ImportAliasReexport.hs" "haskell" + expectNoMoreDiagnostics 3 doc "typecheck" + renameErr <- expectRenameError doc (Position 4 6) "G" + liftIO $ do + renameErr ^. L.code @?= InR ErrorCodes_InvalidParams + let errMessage = renameErr ^. L.message + assertBool + ("expected error due to ambiguous alias, but got: " <> unpack errMessage) + ("Alias ‘F’ is ambiguous" `isInfixOf` errMessage) , goldenWithRename "Imported function" "ImportedFunction" $ \doc -> rename doc (Position 3 8) "baz" , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> @@ -101,7 +168,7 @@ renameTests = testGroup "Identifier" rename doc (Position 4 23) "blah" , goldenWithRename "Let expression" "LetExpression" $ \doc -> rename doc (Position 5 11) "foobar" - , goldenWithRename "Qualified as" "QualifiedAs" $ \doc -> + , goldenWithRename "Qualified-as function" "QualifiedAsFunction" $ \doc -> rename doc (Position 3 10) "baz" , goldenWithRename "Qualified shadowing" "QualifiedShadowing" $ \doc -> rename doc (Position 3 12) "foobar" diff --git a/plugins/hls-rename-plugin/test/testdata/Foo.hs b/plugins/hls-rename-plugin/test/testdata/Foo.hs index c4850149b4..220abc87d8 100644 --- a/plugins/hls-rename-plugin/test/testdata/Foo.hs +++ b/plugins/hls-rename-plugin/test/testdata/Foo.hs @@ -2,3 +2,6 @@ module Foo where foo :: Int -> Int foo x = 0 + +(!) :: Int -> Int -> Int +(!) x y = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportAlias.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportAlias.expected.hs new file mode 100644 index 0000000000..2a0a8c3f38 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportAlias.expected.hs @@ -0,0 +1,9 @@ +import Foo ((!)) +import Foo as G +import Missing.Module as M + +bar :: Int -> Int +bar = G.foo + +baz :: Int -> Int -> Int +baz = (!) diff --git a/plugins/hls-rename-plugin/test/testdata/ImportAlias.hs b/plugins/hls-rename-plugin/test/testdata/ImportAlias.hs new file mode 100644 index 0000000000..46241ed2a9 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportAlias.hs @@ -0,0 +1,9 @@ +import Foo ((!)) +import Foo as 𝐹𝔽 +import Missing.Module as M + +bar :: Int -> Int +bar = 𝐹𝔽.foo + +baz :: Int -> Int -> Int +baz = (!) diff --git a/plugins/hls-rename-plugin/test/testdata/ImportAliasReexport.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportAliasReexport.expected.hs new file mode 100644 index 0000000000..798d0a15c9 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportAliasReexport.expected.hs @@ -0,0 +1,11 @@ +import Data.Foldable as F +import Prelude as Reexport + +baz :: Foldable t => (a -> b -> b) -> b -> t a -> b +baz = Reexport.foldr + +bar :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +bar = F.traverse_ + +bux :: Foldable t => (b -> a -> b) -> b -> t a -> b +bux = Reexport.foldl diff --git a/plugins/hls-rename-plugin/test/testdata/ImportAliasReexport.hs b/plugins/hls-rename-plugin/test/testdata/ImportAliasReexport.hs new file mode 100644 index 0000000000..30942d9bc7 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportAliasReexport.hs @@ -0,0 +1,11 @@ +import Data.Foldable as F +import Prelude as F + +baz :: Foldable t => (a -> b -> b) -> b -> t a -> b +baz = F.foldr + +bar :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +bar = F.traverse_ + +bux :: Foldable t => (b -> a -> b) -> b -> t a -> b +bux = F.foldl diff --git a/plugins/hls-rename-plugin/test/testdata/ImportAliasShared.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportAliasShared.expected.hs new file mode 100644 index 0000000000..7f7f28aa2b --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportAliasShared.expected.hs @@ -0,0 +1,7 @@ +module ImportAliasShared (Maybe.fromMaybe, M.mapM) where + +import qualified Control.Monad as M +import qualified Data.Maybe as Maybe + +bar :: Maybe a -> Bool +bar = Maybe.isJust diff --git a/plugins/hls-rename-plugin/test/testdata/ImportAliasShared.hs b/plugins/hls-rename-plugin/test/testdata/ImportAliasShared.hs new file mode 100644 index 0000000000..20fecf5b42 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportAliasShared.hs @@ -0,0 +1,7 @@ +module ImportAliasShared (M.fromMaybe, M.mapM) where + +import qualified Control.Monad as M +import qualified Data.Maybe as M + +bar :: Maybe a -> Bool +bar = M.isJust diff --git a/plugins/hls-rename-plugin/test/testdata/PrepareRename.hs b/plugins/hls-rename-plugin/test/testdata/PrepareRename.hs index e5271d3454..7e3f5f1769 100644 --- a/plugins/hls-rename-plugin/test/testdata/PrepareRename.hs +++ b/plugins/hls-rename-plugin/test/testdata/PrepareRename.hs @@ -1,4 +1,4 @@ -module PrepareRename where +module PrepareRename (bar, F.foo) where import qualified Foo as F diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedAsFunction.expected.hs similarity index 100% rename from plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs rename to plugins/hls-rename-plugin/test/testdata/QualifiedAsFunction.expected.hs diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedAsFunction.hs similarity index 100% rename from plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs rename to plugins/hls-rename-plugin/test/testdata/QualifiedAsFunction.hs diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml index 892a7d675f..b4d943cae4 100644 --- a/plugins/hls-rename-plugin/test/testdata/hie.yaml +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -9,11 +9,14 @@ cradle: - "FunctionName" - "Gadt" - "HiddenFunction" + - "ImportAlias" + - "ImportAliasReexport" + - "ImportAliasShared" - "ImportHiding" - "ImportedFunction" - "IndirectPuns" - "LetExpression" - - "QualifiedAs" + - "QualifiedAsFunction" - "QualifiedFunction" - "QualifiedShadowing" - "RealignDo"