diff --git a/hls-rename-plugin.cabal b/hls-rename-plugin.cabal --- a/hls-rename-plugin.cabal +++ b/hls-rename-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-rename-plugin -version: 1.0.0.1 +version: 1.0.0.2 synopsis: Rename plugin for Haskell Language Server description: Please see the README on GitHub at @@ -25,14 +25,17 @@ , extra , ghc , ghc-exactprint - , ghcide ^>=1.6 + , ghcide ^>= 1.6 || ^>=1.7 + , hashable , hiedb - , hls-plugin-api ^>=1.3 + , hls-plugin-api ^>= 1.3 || ^>=1.4 , lsp , lsp-types + , mod , syb , text , transformers + , unordered-containers default-language: Haskell2010 @@ -43,7 +46,10 @@ main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: + , aeson , base + , containers , filepath + , hls-plugin-api , hls-rename-plugin - , hls-test-utils ^>=1.2 + , hls-test-utils ^>=1.3 diff --git a/src/Ide/Plugin/Rename.hs b/src/Ide/Plugin/Rename.hs --- a/src/Ide/Plugin/Rename.hs +++ b/src/Ide/Plugin/Rename.hs @@ -1,188 +1,251 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Ide.Plugin.Rename (descriptor) where +#if MIN_VERSION_ghc(9,2,1) +import GHC.Parser.Annotation (AnnContext, AnnList, AnnParen, AnnPragma) +#endif + import Control.Monad -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except -import Data.Containers.ListUtils import Data.Generics -import Data.List.Extra hiding (nubOrd, replace) -import qualified Data.Map as M +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.Hashable +import Data.List.Extra +import qualified Data.Map as M import Data.Maybe -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) +import Data.Mod.Word +import qualified Data.Text as T import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Parser +import Development.IDE.GHC.Compat.Units +import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.AtPoint -#if MIN_VERSION_ghc(9,2,1) -import GHC.Parser.Annotation (AnnContext, AnnList, - AnnParen, AnnPragma) -#endif -#if MIN_VERSION_ghc(9,0,1) -import GHC.Types.Name -#else -import Name -#endif -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) +import Development.IDE.Types.Location import HieDb.Query import Ide.Plugin.Config +import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types -import Language.Haskell.GHC.ExactPrint import Language.LSP.Server import Language.LSP.Types +instance Hashable Location +instance Hashable Range +instance Hashable Position +instance Hashable UInt +instance Hashable (Mod a) where hash n = hash (unMod n) + descriptor :: PluginId -> PluginDescriptor IdeState -descriptor pluginId = (defaultPluginDescriptor pluginId) { - pluginHandlers = mkPluginHandler STextDocumentRename renameProvider -} +descriptor pluginId = (defaultPluginDescriptor pluginId) + { pluginHandlers = mkPluginHandler STextDocumentRename renameProvider + , pluginConfigDescriptor = defaultConfigDescriptor + { configCustomConfig = mkCustomConfig properties } + } renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) = response $ do nfp <- safeUriToNfp uri oldName <- getNameAtPos state nfp pos - workspaceRefs <- refsAtName state nfp oldName - let filesRefs = groupOn locToUri workspaceRefs - getFileEdits = ap (getSrcEdits state . renameModRefs newNameText) (locToUri . head) - fileEdits <- mapM getFileEdits filesRefs + refLocs <- refsAtName state nfp oldName + crossModuleEnabled <- lift $ usePropertyLsp #crossModule pluginId properties + unless crossModuleEnabled $ failWhenImportOrExport state nfp refLocs oldName + when (isBuiltInSyntax oldName) $ + throwE ("Invalid rename of built-in syntax: \"" ++ showName oldName ++ "\"") + let newName = mkTcOcc $ T.unpack newNameText + filesRefs = collectWith locToUri refLocs + getFileEdit = flip $ getSrcEdit state . renameRefs newName + fileEdits <- mapM (uncurry getFileEdit) filesRefs pure $ foldl' (<>) mempty fileEdits -------------------------------------------------------------------------------- +-- | Limit renaming across modules. +failWhenImportOrExport :: + (MonadLsp config m) => + IdeState -> + NormalizedFilePath -> + HashSet Location -> + Name -> + ExceptT String m () +failWhenImportOrExport state nfp refLocs name = do + pm <- handleMaybeM ("No parsed module for: " ++ show nfp) $ liftIO $ runAction + "Rename.GetParsedModule" + state + (use GetParsedModule nfp) + let hsMod = unLoc $ pm_parsed_source pm + case (unLoc <$> hsmodName hsMod, hsmodExports hsMod) of + (mbModName, _) | not $ nameIsLocalOrFrom (replaceModName name mbModName) name + -> throwE "Renaming of an imported name is unsupported" + (_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports + -> throwE "Renaming of an exported name is unsupported" + (Just _, Nothing) -> throwE "Explicit export list required for renaming" + _ -> pure () + +--------------------------------------------------------------------------------------------------- -- Source renaming --- | Compute a `WorkspaceEdit` by applying a given function to the `ParsedModule` for a given `Uri`. -getSrcEdits :: +-- | Apply a function to a `ParsedSource` for a given `Uri` to compute a `WorkspaceEdit`. +getSrcEdit :: (MonadLsp config m) => IdeState -> -#if MIN_VERSION_ghc(9,0,1) - (HsModule -> HsModule) -> -#else - (HsModule GhcPs -> HsModule GhcPs) -> -#endif + (ParsedSource -> ParsedSource) -> Uri -> ExceptT String m WorkspaceEdit -getSrcEdits state updateMod uri = do +getSrcEdit state updatePs uri = do ccs <- lift getClientCapabilities nfp <- safeUriToNfp uri - annotatedAst <- - handleMaybeM "Error: could not get parsed source" $ liftIO $ runAction - "Rename.GetParsedModuleWithComments" - state - (use GetAnnotatedParsedSource nfp) - let (ps, anns) = (astA annotatedAst, annsA annotatedAst) + annAst <- handleMaybeM ("No parsed source for: " ++ show nfp) $ liftIO $ runAction + "Rename.GetAnnotatedParsedSource" + state + (use GetAnnotatedParsedSource nfp) + let (ps, anns) = (astA annAst, annsA annAst) #if !MIN_VERSION_ghc(9,2,1) let src = T.pack $ exactPrint ps anns - res = T.pack $ exactPrint (updateMod <$> ps) anns + res = T.pack $ exactPrint (updatePs ps) anns #else let src = T.pack $ exactPrint ps - res = T.pack $ exactPrint (updateMod <$> ps) + res = T.pack $ exactPrint (updatePs ps) #endif - pure $ diffText ccs (uri, src) res IncludeDeletions --- | Replace a name at every given `Location` (in a given `HsModule`) with a given new name. -renameModRefs :: - T.Text -> - [Location] -> -#if MIN_VERSION_ghc(9,0,1) - HsModule - -> HsModule -#else - HsModule GhcPs - -> HsModule GhcPs -#endif +-- | Replace names at every given `Location` (in a given `ParsedSource`) with a given new name. +renameRefs :: + OccName -> + HashSet Location -> + ParsedSource -> + ParsedSource #if MIN_VERSION_ghc(9,2,1) -renameModRefs newNameText refs = everywhere $ +renameRefs newName refs = everywhere $ -- there has to be a better way... - mkT (replace @AnnListItem) `extT` - -- replace @AnnList `extT` -- not needed - -- replace @AnnParen `extT` -- not needed - -- replace @AnnPragma `extT` -- not needed - -- replace @AnnContext `extT` -- not needed - -- replace @NoEpAnns `extT` -- not needed - replace @NameAnn + 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 where - replace :: forall an. Typeable an => LocatedAn an RdrName -> LocatedAn an RdrName - replace (L srcSpan oldRdrName) - | isRef (locA srcSpan) = L srcSpan $ newRdrName oldRdrName - replace lOldRdrName = lOldRdrName + replaceLoc :: forall an. Typeable an => LocatedAn an RdrName -> LocatedAn an RdrName + replaceLoc (L srcSpan oldRdrName) + | isRef (locA srcSpan) = L srcSpan $ replace oldRdrName + replaceLoc lOldRdrName = lOldRdrName #else -renameModRefs newNameText refs = everywhere $ mkT replace +renameRefs newName refs = everywhere $ mkT replaceLoc where - replace :: Located RdrName -> Located RdrName - replace (L srcSpan oldRdrName) - | isRef srcSpan = L srcSpan $ newRdrName oldRdrName - replace lOldRdrName = lOldRdrName + replaceLoc :: Located RdrName -> Located RdrName + replaceLoc (L srcSpan oldRdrName) + | isRef srcSpan = L srcSpan $ replace oldRdrName + replaceLoc lOldRdrName = lOldRdrName #endif - isRef :: SrcSpan -> Bool - isRef = (`elem` refs) . fromJust . srcSpanToLocation + replace :: RdrName -> RdrName + replace (Qual modName _) = Qual modName newName + replace _ = Unqual newName - newRdrName :: RdrName -> RdrName - newRdrName oldRdrName = case oldRdrName of - Qual modName _ -> Qual modName newOccName - _ -> Unqual newOccName + isRef :: SrcSpan -> Bool + isRef = (`elem` refs) . unsafeSrcSpanToLoc - newOccName = mkTcOcc $ T.unpack newNameText -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- Reference finding -- | Note: We only find exact name occurences (i.e. type reference "depth" is 0). -refsAtName :: IdeState -> NormalizedFilePath -> Name -> ExceptT [Char] (LspT Config IO) [Location] +refsAtName :: + MonadIO m => + IdeState -> + NormalizedFilePath -> + Name -> + ExceptT String m (HashSet Location) refsAtName state nfp name = do ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras ast <- safeGetHieAst state nfp - astRefs <- handleMaybe "Error: Could not get name AST references" $ getNameAstLocations name ast dbRefs <- case nameModule_maybe name of Nothing -> pure [] - Just mod -> liftIO $ mapMaybe rowToLoc <$> - withHieDb (\hieDb -> - findReferences - hieDb - True - (nameOccName name) - (Just $ moduleName mod) - (Just $ moduleUnit mod) - [fromNormalizedFilePath nfp] - ) - pure $ nubOrd $ astRefs ++ dbRefs + Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb -> + findReferences + hieDb + True + (nameOccName name) + (Just $ moduleName mod) + (Just $ moduleUnit mod) + [fromNormalizedFilePath nfp] + ) + pure $ HS.fromList $ getNameLocs name ast ++ dbRefs -getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] -getNameAstLocations name (HAR _ _ rm _ _, mapping) = - mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm +getNameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location] +getNameLocs name (HAR _ _ rm _ _, pm) = + mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst) + (concat $ M.lookup (Right name) rm) -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- Util getNameAtPos :: IdeState -> NormalizedFilePath -> Position -> ExceptT String (LspT Config IO) Name getNameAtPos state nfp pos = do - (HAR{hieAst}, mapping) <- safeGetHieAst state nfp - handleMaybe "Error: could not find name at position" $ listToMaybe $ - getAstNamesAtPoint hieAst pos mapping - -nfpToUri :: NormalizedFilePath -> Uri -nfpToUri = filePathToUri . fromNormalizedFilePath - -safeUriToNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath -safeUriToNfp = handleMaybe "Error: Could not get uri" . fmap toNormalizedFilePath . uriToFilePath + (HAR{hieAst}, pm) <- safeGetHieAst state nfp + handleMaybe ("No name at " ++ showPos pos) $ listToMaybe $ getNamesAtPoint hieAst pos pm safeGetHieAst :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m (HieAstResult, PositionMapping) -safeGetHieAst state = handleMaybeM "Error: Could not get AST" . liftIO . - runAction "Rename.GetHieAst" state . useWithStale GetHieAst +safeGetHieAst state nfp = handleMaybeM + ("No AST for file: " ++ show nfp) + (liftIO $ runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp) +safeUriToNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath +safeUriToNfp uri = handleMaybe + ("No filepath for uri: " ++ show uri) + (toNormalizedFilePath <$> uriToFilePath uri) + +-- head is safe since groups are non-empty +collectWith :: (Hashable a, Eq a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] +collectWith f = map (\a -> (f $ head a, HS.fromList a)) . groupOn f . HS.toList + locToUri :: Location -> Uri locToUri (Location uri _) = uri + +nfpToUri :: NormalizedFilePath -> Uri +nfpToUri = filePathToUri . fromNormalizedFilePath + +showName :: Name -> String +showName = occNameString . getOccName + +showPos :: Position -> String +showPos Position{_line, _character} = "line: " ++ show _line ++ " - character: " ++ show _character + +unsafeSrcSpanToLoc :: SrcSpan -> Location +unsafeSrcSpanToLoc srcSpan = + case srcSpanToLocation srcSpan of + Nothing -> error "Invalid conversion from UnhelpfulSpan to Location" + Just location -> location + +replaceModName :: Name -> Maybe ModuleName -> Module +replaceModName name mbModName = + mkModule (moduleUnit $ nameModule name) (fromMaybe (mkModuleName "Main") mbModName) + +--------------------------------------------------------------------------------------------------- +-- Config + +properties :: Properties '[ 'PropertyKey "crossModule" 'TBoolean] +properties = emptyProperties + & defineBooleanProperty #crossModule + "Enable experimental cross-module renaming" False diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,9 @@ module Main (main) where +import Data.Aeson +import qualified Data.Map as M +import Ide.Plugin.Config import qualified Ide.Plugin.Rename as Rename import System.FilePath import Test.Hls @@ -14,47 +17,51 @@ tests :: TestTree tests = testGroup "Rename" - [ goldenWithRename "Data constructor" "DataConstructor" $ \doc -> do + [ goldenWithRename "Data constructor" "DataConstructor" $ \doc -> rename doc (Position 0 15) "Op" - , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> do + , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> rename doc (Position 2 1) "quux" - , goldenWithRename "Function argument" "FunctionArgument" $ \doc -> do + , goldenWithRename "Function argument" "FunctionArgument" $ \doc -> rename doc (Position 3 4) "y" - , goldenWithRename "Function name" "FunctionName" $ \doc -> do + , goldenWithRename "Function name" "FunctionName" $ \doc -> rename doc (Position 3 1) "baz" - , goldenWithRename "GADT" "Gadt" $ \doc -> do + , goldenWithRename "GADT" "Gadt" $ \doc -> rename doc (Position 6 37) "Expr" - , goldenWithRename "Hidden function" "HiddenFunction" $ \doc -> do + , goldenWithRename "Hidden function" "HiddenFunction" $ \doc -> rename doc (Position 0 32) "quux" - , goldenWithRename "Imported function" "ImportedFunction" $ \doc -> do + , goldenWithRename "Imported function" "ImportedFunction" $ \doc -> rename doc (Position 3 8) "baz" - , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> do + , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> rename doc (Position 0 22) "hiddenFoo" - , goldenWithRename "Let expression" "LetExpression" $ \doc -> do + , goldenWithRename "Let expression" "LetExpression" $ \doc -> rename doc (Position 5 11) "foobar" - , goldenWithRename "Qualified as" "QualifiedAs" $ \doc -> do + , goldenWithRename "Qualified as" "QualifiedAs" $ \doc -> rename doc (Position 3 10) "baz" - , goldenWithRename "Qualified shadowing" "QualifiedShadowing" $ \doc -> do + , goldenWithRename "Qualified shadowing" "QualifiedShadowing" $ \doc -> rename doc (Position 3 12) "foobar" - , goldenWithRename "Qualified function" "QualifiedFunction" $ \doc -> do + , goldenWithRename "Qualified function" "QualifiedFunction" $ \doc -> rename doc (Position 3 12) "baz" - , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc -> do + , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc -> rename doc (Position 0 2) "fooBarQuux" - , goldenWithRename "Record field" "RecordField" $ \doc -> do + , goldenWithRename "Record field" "RecordField" $ \doc -> rename doc (Position 6 9) "number" - , goldenWithRename "Shadowed name" "ShadowedName" $ \doc -> do + , goldenWithRename "Shadowed name" "ShadowedName" $ \doc -> rename doc (Position 1 1) "baz" - , goldenWithRename "Typeclass" "Typeclass" $ \doc -> do + , goldenWithRename "Typeclass" "Typeclass" $ \doc -> rename doc (Position 8 15) "Equal" - , goldenWithRename "Type constructor" "TypeConstructor" $ \doc -> do + , goldenWithRename "Type constructor" "TypeConstructor" $ \doc -> rename doc (Position 2 17) "BinaryTree" - , goldenWithRename "Type variable" "TypeVariable" $ \doc -> do + , goldenWithRename "Type variable" "TypeVariable" $ \doc -> rename doc (Position 0 13) "b" ] -goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithRename title path = - goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" +goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithRename title path act = + goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" $ \doc -> do + sendConfigurationChanged $ toJSON $ + def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] } + act doc + testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/test/testdata/FunctionArgument.expected.hs b/test/testdata/FunctionArgument.expected.hs --- a/test/testdata/FunctionArgument.expected.hs +++ b/test/testdata/FunctionArgument.expected.hs @@ -1,4 +1,4 @@ -module FunctionArgument where +module FunctionArgument () where foo :: Int -> Int foo y = y + 1 diff --git a/test/testdata/FunctionArgument.hs b/test/testdata/FunctionArgument.hs --- a/test/testdata/FunctionArgument.hs +++ b/test/testdata/FunctionArgument.hs @@ -1,4 +1,4 @@ -module FunctionArgument where +module FunctionArgument () where foo :: Int -> Int foo x = x + 1 diff --git a/test/testdata/LetExpression.expected.hs b/test/testdata/LetExpression.expected.hs --- a/test/testdata/LetExpression.expected.hs +++ b/test/testdata/LetExpression.expected.hs @@ -1,4 +1,4 @@ -module Let where +module Let () where import Foo diff --git a/test/testdata/LetExpression.hs b/test/testdata/LetExpression.hs --- a/test/testdata/LetExpression.hs +++ b/test/testdata/LetExpression.hs @@ -1,4 +1,4 @@ -module Let where +module Let () where import Foo diff --git a/test/testdata/Typeclass.expected.hs b/test/testdata/Typeclass.expected.hs --- a/test/testdata/Typeclass.expected.hs +++ b/test/testdata/Typeclass.expected.hs @@ -1,4 +1,4 @@ -module Typeclass where +module Typeclass () where class Equal a where equals :: a -> a -> Bool diff --git a/test/testdata/Typeclass.hs b/test/testdata/Typeclass.hs --- a/test/testdata/Typeclass.hs +++ b/test/testdata/Typeclass.hs @@ -1,4 +1,4 @@ -module Typeclass where +module Typeclass () where class Equality a where equals :: a -> a -> Bool