hls-rename-plugin 1.0.0.1 → 1.0.0.2

raw patch · 9 files changed

+214/−138 lines, 9 filesdep +aesondep +hashabledep +moddep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsnew-uploaderPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: aeson, hashable, mod, unordered-containers

Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils

API changes (from Hackage documentation)

Files

• hls-rename-plugin.cabal +10/−4
• src/Ide/Plugin/Rename.hs +170/−107
• test/Main.hs +28/−21
• test/testdata/FunctionArgument.expected.hs +1/−1
• test/testdata/FunctionArgument.hs +1/−1
• test/testdata/LetExpression.expected.hs +1/−1
• test/testdata/LetExpression.hs +1/−1
• test/testdata/Typeclass.expected.hs +1/−1
• test/testdata/Typeclass.hs +1/−1

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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

@@ -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

@@ -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"

@@ -1,4 +1,4 @@-module FunctionArgument where+module FunctionArgument () where  foo :: Int -> Int foo y = y + 1

@@ -1,4 +1,4 @@-module FunctionArgument where+module FunctionArgument () where  foo :: Int -> Int foo x = x + 1

@@ -1,4 +1,4 @@-module Let where+module Let () where  import Foo 

@@ -1,4 +1,4 @@-module Let where+module Let () where  import Foo 

@@ -1,4 +1,4 @@-module Typeclass where+module Typeclass () where  class Equal a where     equals :: a -> a -> Bool

@@ -1,4 +1,4 @@-module Typeclass where+module Typeclass () where  class Equality a where     equals :: a -> a -> Bool