From e21bb6b43fceb435db5beaee4920872f34008169 Mon Sep 17 00:00:00 2001 From: Oliver Madine <“30090176+OliverMadine@users.noreply.github.com”> Date: Tue, 13 Apr 2021 16:16:49 +0100 Subject: [PATCH 01/49] Added rename symbol implementation (does not work for types yet) in RenameSymbol plugin --- exe/Plugins.hs | 2 + .../Development/IDE/LSP/HoverDefinition.hs | 1 + haskell-language-server.cabal | 10 +++ .../default/src/Ide/Plugin/RenameSymbol.hs | 62 +++++++++++++++++++ 4 files changed, 75 insertions(+) create mode 100644 plugins/default/src/Ide/Plugin/RenameSymbol.hs diff --git a/exe/Plugins.hs b/exe/Plugins.hs index d6c37789fa..8f05c1e521 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -10,6 +10,7 @@ import Development.IDE (IdeState) import Development.IDE.Plugin.HLS.GhcIde as GhcIde import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 +import Ide.Plugin.RenameSymbol as RenameSymbol -- haskell-language-server optional plugins @@ -125,6 +126,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #if importLens ExplicitImports.descriptor "importLens" : #endif + RenameSymbol.descriptor "renameSymbol" : #if moduleName ModuleName.descriptor "moduleName" : #endif diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 97a5a3e065..b82be1cf9b 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -10,6 +10,7 @@ module Development.IDE.LSP.HoverDefinition , hover , gotoDefinition , gotoTypeDefinition + , references ) where import Control.Monad.IO.Class diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 872997da48..7e37dc1b27 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -123,6 +123,11 @@ flag importLens default: True manual: True +flag renameSymbol + description: Enable renameSymbol plugin + default: True + manual: True + flag retrie description: Enable retrie plugin default: True @@ -185,6 +190,10 @@ common example-plugins other-modules: Ide.Plugin.Example, Ide.Plugin.Example2 +common renameSymbol + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.RenameSymbol + common class if flag(class) || flag(all-plugins) build-depends: hls-class-plugin ^>= 1.0.0.0 @@ -279,6 +288,7 @@ executable haskell-language-server , haddockComments , eval , importLens + , renameSymbol , retrie , tactic , hlint diff --git a/plugins/default/src/Ide/Plugin/RenameSymbol.hs b/plugins/default/src/Ide/Plugin/RenameSymbol.hs new file mode 100644 index 0000000000..11f069a986 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/RenameSymbol.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +-- TODO: explicit export list +module Ide.Plugin.RenameSymbol where + +import Data.Function +import Data.HashMap.Internal hiding (map) +import Data.List +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.LSP.HoverDefinition +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor pluginId = (defaultPluginDescriptor pluginId) { + pluginHandlers = mconcat + [ mkPluginHandler STextDocumentRename renameProvider + -- , mkPluginHandler STextDocumentCodeLens codeLensProvider + ] +} + +renameProvider :: PluginMethodHandler IdeState TextDocumentRename +renameProvider + state + _pluginId + (RenameParams tdi pos _progToken name) + = do + locs <- getTextEdits state tdi pos name + return $ Right (WorkspaceEdit { + _changes=Just (fromList locs), + _documentChanges=Nothing, + _changeAnnotations=Nothing + }) + +getTextEdits :: IdeState + -> TextDocumentIdentifier + -> Position + -> T.Text + -> LspT c IO [(Uri, List TextEdit)] +getTextEdits state tdi pos name + = do + mbLocs <- references state $ ReferenceParams tdi pos Nothing Nothing (ReferenceContext False) + case mbLocs of + Right (List locs) + -> return + $ map ((\(uri':_,tes) -> (uri', List tes)) . unzip) + $ groupBy ((==) `on` fst) [(uri, TextEdit range name) | Location uri range <- locs] + _ -> return [] + +-- helloWorldLens :: CodeLens +-- helloWorldLens = CodeLens +-- { _range = Range (Position 0 0) (Position 0 1) +-- , _command = Just $ Command "Hello, World!" "hello-world-command-id" Nothing +-- , _xdata = Nothing +-- } + +-- codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens +-- codeLensProvider _ _ _ +-- = do return $ Right $ List [helloWorldLens] From 3c57f8cdeca43ccc346bcc93066560259c61101e Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 30 May 2021 03:55:05 +0100 Subject: [PATCH 02/49] renamed RenameSymbol.hs plugin to Rename.hs, cleaned initial file structure, created CPP flag --- exe/Plugins.hs | 9 ++- haskell-language-server.cabal | 16 ++--- plugins/default/src/Ide/Plugin/Rename.hs | 41 ++++++++++++ .../default/src/Ide/Plugin/RenameSymbol.hs | 62 ------------------- 4 files changed, 57 insertions(+), 71 deletions(-) create mode 100644 plugins/default/src/Ide/Plugin/Rename.hs delete mode 100644 plugins/default/src/Ide/Plugin/RenameSymbol.hs diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 8f05c1e521..4e6f4bda51 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -10,7 +10,6 @@ import Development.IDE (IdeState) import Development.IDE.Plugin.HLS.GhcIde as GhcIde import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 -import Ide.Plugin.RenameSymbol as RenameSymbol -- haskell-language-server optional plugins @@ -34,6 +33,10 @@ import Ide.Plugin.ExplicitImports as ExplicitImports import Ide.Plugin.Retrie as Retrie #endif +#if rename +import Ide.Plugin.Rename as Rename +#endif + #if tactic import Ide.Plugin.Tactic as Tactic #endif @@ -111,6 +114,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #if retrie Retrie.descriptor "retrie" : #endif +#if rename + Rename.descriptor "rename" : +#endif #if brittany Brittany.descriptor "brittany" : #endif @@ -126,7 +132,6 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #if importLens ExplicitImports.descriptor "importLens" : #endif - RenameSymbol.descriptor "renameSymbol" : #if moduleName ModuleName.descriptor "moduleName" : #endif diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 7e37dc1b27..0f08790671 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -123,8 +123,8 @@ flag importLens default: True manual: True -flag renameSymbol - description: Enable renameSymbol plugin +flag rename + description: Enable rename plugin default: True manual: True @@ -190,10 +190,6 @@ common example-plugins other-modules: Ide.Plugin.Example, Ide.Plugin.Example2 -common renameSymbol - hs-source-dirs: plugins/default/src - other-modules: Ide.Plugin.RenameSymbol - common class if flag(class) || flag(all-plugins) build-depends: hls-class-plugin ^>= 1.0.0.0 @@ -214,6 +210,12 @@ common importLens build-depends: hls-explicit-imports-plugin ^>= 1.0.0.0 cpp-options: -DimportLens +common rename + if flag(rename) || flag(all-plugins) + hs-source-dirs: plugins/default/src + other-modules: Ide.Plugin.Rename + cpp-options: -Drename + common retrie if flag(retrie) || flag(all-plugins) build-depends: hls-retrie-plugin ^>= 1.0.0.0 @@ -288,7 +290,7 @@ executable haskell-language-server , haddockComments , eval , importLens - , renameSymbol + , rename , retrie , tactic , hlint diff --git a/plugins/default/src/Ide/Plugin/Rename.hs b/plugins/default/src/Ide/Plugin/Rename.hs new file mode 100644 index 0000000000..31c87a3dbc --- /dev/null +++ b/plugins/default/src/Ide/Plugin/Rename.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Ide.Plugin.Rename (descriptor) where + +import Data.Function +import Data.HashMap.Internal hiding (map) +import Data.List +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.LSP.HoverDefinition +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor pluginId = (defaultPluginDescriptor pluginId) { + pluginHandlers = mkPluginHandler STextDocumentRename renameProvider +} + +renameProvider :: PluginMethodHandler IdeState TextDocumentRename +renameProvider state _pluginId (RenameParams tdi pos _progToken name) = do + locs <- getTextEdits state tdi pos name + return $ Right (WorkspaceEdit { + _changes = Just (fromList locs), + _documentChanges = Nothing, + _changeAnnotations = Nothing + }) + +getTextEdits :: IdeState + -> TextDocumentIdentifier + -> Position + -> T.Text + -> LspT c IO [(Uri, List TextEdit)] +getTextEdits state tdi pos name = do + mbLocs <- references state $ ReferenceParams tdi pos Nothing Nothing (ReferenceContext False) + case mbLocs of + Right (List locs) + -> return + $ map ((\(uri':_,tes) -> (uri', List tes)) . unzip) + $ groupBy ((==) `on` fst) [(uri, TextEdit range name) | Location uri range <- locs] + _ -> return [] diff --git a/plugins/default/src/Ide/Plugin/RenameSymbol.hs b/plugins/default/src/Ide/Plugin/RenameSymbol.hs deleted file mode 100644 index 11f069a986..0000000000 --- a/plugins/default/src/Ide/Plugin/RenameSymbol.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - --- TODO: explicit export list -module Ide.Plugin.RenameSymbol where - -import Data.Function -import Data.HashMap.Internal hiding (map) -import Data.List -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.LSP.HoverDefinition -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor pluginId = (defaultPluginDescriptor pluginId) { - pluginHandlers = mconcat - [ mkPluginHandler STextDocumentRename renameProvider - -- , mkPluginHandler STextDocumentCodeLens codeLensProvider - ] -} - -renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider - state - _pluginId - (RenameParams tdi pos _progToken name) - = do - locs <- getTextEdits state tdi pos name - return $ Right (WorkspaceEdit { - _changes=Just (fromList locs), - _documentChanges=Nothing, - _changeAnnotations=Nothing - }) - -getTextEdits :: IdeState - -> TextDocumentIdentifier - -> Position - -> T.Text - -> LspT c IO [(Uri, List TextEdit)] -getTextEdits state tdi pos name - = do - mbLocs <- references state $ ReferenceParams tdi pos Nothing Nothing (ReferenceContext False) - case mbLocs of - Right (List locs) - -> return - $ map ((\(uri':_,tes) -> (uri', List tes)) . unzip) - $ groupBy ((==) `on` fst) [(uri, TextEdit range name) | Location uri range <- locs] - _ -> return [] - --- helloWorldLens :: CodeLens --- helloWorldLens = CodeLens --- { _range = Range (Position 0 0) (Position 0 1) --- , _command = Just $ Command "Hello, World!" "hello-world-command-id" Nothing --- , _xdata = Nothing --- } - --- codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens --- codeLensProvider _ _ _ --- = do return $ Right $ List [helloWorldLens] From 966ead0d9a488a6acd3b76f67336a5d013d130dc Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 30 May 2021 21:21:16 +0100 Subject: [PATCH 03/49] removed default cabal main file, declared rename capability --- ghcide/test/exe/Main.hs | 2 +- plugins/hls-rename-plugin/Main.hs | 4 ---- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 1 + 3 files changed, 2 insertions(+), 5 deletions(-) delete mode 100644 plugins/hls-rename-plugin/Main.hs diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index e8f8a8bcee..aed16a489a 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -188,7 +188,7 @@ initializeResponseTests = withResource acquire release tests where _documentRangeFormattingProvider (Just $ InL False) , chk "NO doc formatting on typing" _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ InL False) + , chk " renaming" _renameProvider (Just $ InL True) , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) diff --git a/plugins/hls-rename-plugin/Main.hs b/plugins/hls-rename-plugin/Main.hs deleted file mode 100644 index 65ae4a05d5..0000000000 --- a/plugins/hls-rename-plugin/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 369a7f2052..cf16679cde 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} + module Ide.Plugin.Rename (descriptor) where import Data.Function From 6634bc54865a45961fad4a0fc2261a24076c552d Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 30 May 2021 22:57:03 +0100 Subject: [PATCH 04/49] initial test cases --- plugins/hls-rename-plugin/test/Main.hs | 21 ++++++++++++++++++- .../test/testdata/DataConstructor.expected.hs | 4 ++++ .../test/testdata/DataConstructor.hs | 4 ++++ .../testdata/FunctionArgument.expected.hs | 4 ++++ .../test/testdata/FunctionArgument.hs | 4 ++++ .../testdata/ImportedFunction.expected.hs | 4 ++++ .../test/testdata/ImportedFunction.hs | 4 ++++ .../testdata/QualifiedFunction.expected.hs | 4 ++++ .../test/testdata/QualifiedFunction.hs | 4 ++++ .../test/testdata/RecordField.expected.hs | 7 +++++++ .../test/testdata/RecordField.hs | 7 +++++++ .../test/testdata/ShadowedName.expected.hs | 4 ++++ .../test/testdata/ShadowedName.hs | 4 ++++ .../test/testdata/TypeConstructor.expected.hs | 4 ++++ .../test/testdata/TypeConstructor.hs | 4 ++++ .../test/testdata/TypeVariable.expected.hs | 2 ++ .../test/testdata/TypeVariable.hs | 2 ++ .../hls-rename-plugin/test/testdata/hie.yaml | 12 +++++++++++ 18 files changed, 98 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/DataConstructor.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/RecordField.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/ShadowedName.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/TypeVariable.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/hie.yaml diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 20531b4608..1a843c69c3 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -9,12 +9,31 @@ main :: IO () main = defaultTestRunner tests renamePlugin :: PluginDescriptor IdeState -renamePlugin = Rename.descriptor "pragmas" +renamePlugin = Rename.descriptor "rename" tests :: TestTree tests = testGroup "rename" [ goldenWithRename "function name" "FunctionName" $ \doc -> do rename doc (Position 3 1) "baz" -- foo :: Int -> Int + , goldenWithRename "function argument" "FunctionArgument" $ \doc -> do + rename doc (Position 3 4) "y" -- foo x = x + 1 + , ignoreTestBecause "not yet implemented" $ + goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do + rename doc (Position 3 24) "baz" -- bar = FunctionArgument.foo + , goldenWithRename "record field" "RecordField" $ \doc -> do + rename doc (Position 6 9) "number" -- foo Bam {n = y} = Bam {n = y + 5, s = ""} + , goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do + rename doc (Position 3 8) "y" -- x = 20 + , ignoreTestBecause "not yet implemented" $ + goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do + rename doc (Position 2 15) "BinaryTree" -- rotateRight :: Tree a -> Tree a + , goldenWithRename "data constructor" "DataConstructor" $ \doc -> do + rename doc (Position 0 13) "Apply" -- data Expr = Op Int Int + , ignoreTestBecause "not yet implemented" $ + goldenWithRename "type variable" "TypeVariable" $ \doc -> do + rename doc (Position 0 13) "b" -- bar :: Maybe b -> Maybe b + , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do + rename doc (Position 0 35) "baz" -- import FunctionArgument (foo) ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree diff --git a/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs b/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs new file mode 100644 index 0000000000..b614d72291 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs @@ -0,0 +1,4 @@ +data Expr = Apply Int Int + +plus :: Expr -> Expr +plus (Apply n m) = Apply (n + m) 0 diff --git a/plugins/hls-rename-plugin/test/testdata/DataConstructor.hs b/plugins/hls-rename-plugin/test/testdata/DataConstructor.hs new file mode 100644 index 0000000000..b614d72291 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/DataConstructor.hs @@ -0,0 +1,4 @@ +data Expr = Apply Int Int + +plus :: Expr -> Expr +plus (Apply n m) = Apply (n + m) 0 diff --git a/plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs new file mode 100644 index 0000000000..bd8d83b334 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.expected.hs @@ -0,0 +1,4 @@ +module FunctionArgument where + +foo :: Int -> Int +foo y = y + 1 diff --git a/plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs new file mode 100644 index 0000000000..a6006e6fac --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/FunctionArgument.hs @@ -0,0 +1,4 @@ +module FunctionArgument where + +foo :: Int -> Int +foo x = x + 1 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs new file mode 100644 index 0000000000..b8b450c0ae --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs @@ -0,0 +1,4 @@ +import FunctionArgument (baz) + +bar :: Int -> Int +bar = baz diff --git a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs new file mode 100644 index 0000000000..79eb5c4aab --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs @@ -0,0 +1,4 @@ +import FunctionArgument (foo) + +bar :: Int -> Int +bar = foo diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs new file mode 100644 index 0000000000..6b98d6f2a9 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs @@ -0,0 +1,4 @@ +import qualified FunctionArgument + +bar :: Int -> Int +bar = FunctionArgument.baz diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs new file mode 100644 index 0000000000..9bb1832ff0 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs @@ -0,0 +1,4 @@ +import qualified FunctionArgument + +bar :: Int -> Int +bar = FunctionArgument.foo diff --git a/plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs b/plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs new file mode 100644 index 0000000000..6646df611c --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/RecordField.expected.hs @@ -0,0 +1,7 @@ +data Bam = Bam { + number :: Int, + s :: String +} + +foo :: Bam -> Bam +foo Bam {number = y} = Bam {number = y + 5, s = ""} diff --git a/plugins/hls-rename-plugin/test/testdata/RecordField.hs b/plugins/hls-rename-plugin/test/testdata/RecordField.hs new file mode 100644 index 0000000000..873150935d --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/RecordField.hs @@ -0,0 +1,7 @@ +data Bam = Bam { + n :: Int, + s :: String +} + +foo :: Bam -> Bam +foo Bam {n = y} = Bam {n = y + 5, s = ""} diff --git a/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs b/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs new file mode 100644 index 0000000000..ac2da171bf --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs @@ -0,0 +1,4 @@ +foo :: Int -> Int +foo x = y + 10 + where + y = 20 diff --git a/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs b/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs new file mode 100644 index 0000000000..f7fbfc641f --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs @@ -0,0 +1,4 @@ +foo :: Int -> Int +foo x = x + 10 + where + x = 20 diff --git a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs new file mode 100644 index 0000000000..6ee982bdbe --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs @@ -0,0 +1,4 @@ +data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) | Leaf a + +rotateRight :: BinaryTree a -> BinaryTree a +rotateRight (Node v (Node v' l' r') r) = Node v' l' (Node v r' r) diff --git a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs new file mode 100644 index 0000000000..b9593a31ce --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs @@ -0,0 +1,4 @@ +data Tree a = Node a (Tree a) (Tree a) | Leaf a + +rotateRight :: Tree a -> Tree a +rotateRight (Node v (Node v' l' r') r) = Node v' l' (Node v r' r) diff --git a/plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs b/plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs new file mode 100644 index 0000000000..75891f4290 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeVariable.expected.hs @@ -0,0 +1,2 @@ +bar :: Maybe b -> Maybe b +bar a = a diff --git a/plugins/hls-rename-plugin/test/testdata/TypeVariable.hs b/plugins/hls-rename-plugin/test/testdata/TypeVariable.hs new file mode 100644 index 0000000000..782be9a7f3 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/TypeVariable.hs @@ -0,0 +1,2 @@ +bar :: Maybe a -> Maybe a +bar a = a diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..4d89779b67 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -0,0 +1,12 @@ +cradle: + direct: + arguments: + - "FunctionName" + - "FunctionArgument" + - "ImportedFunction" + - "QualifiedFunction" + - "RecordField" + - "ShadowedName" + - "TypeVariable" + - "TypeConstructor" + - "DataConstructor" From c5b6bbff1cef65eca4ef7b2541b83ba9dfaaa048 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 31 May 2021 21:33:58 +0100 Subject: [PATCH 05/49] Renaming of type constructors, Renaming of qualified names --- ghcide/ghcide.cabal | 2 +- .../Development/IDE/LSP/HoverDefinition.hs | 1 - ghcide/src/Development/IDE/Spans/AtPoint.hs | 16 +++- .../hls-rename-plugin/hls-rename-plugin.cabal | 6 +- .../src/Ide/Plugin/Rename.hs | 96 +++++++++++++++---- plugins/hls-rename-plugin/test/Main.hs | 17 ++-- .../test/testdata/TypeConstructor.expected.hs | 1 + .../test/testdata/TypeConstructor.hs | 1 + 8 files changed, 104 insertions(+), 36 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 93388e3ee0..7520e94a34 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 build-type: Simple category: Development name: ghcide -version: 1.3.0.0 +version: 1.3.0.1 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index b82be1cf9b..97a5a3e065 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -10,7 +10,6 @@ module Development.IDE.LSP.HoverDefinition , hover , gotoDefinition , gotoTypeDefinition - , references ) where import Control.Monad.IO.Class diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 4f000e1df6..5f56bc78cf 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -16,6 +16,9 @@ module Development.IDE.Spans.AtPoint ( , computeTypeReferences , FOIReferences(..) , defRowToSymbolInfo + , rowToLoc + , getNamesAtPoint + , toCurrentLocation ) where import Development.IDE.GHC.Error @@ -88,8 +91,7 @@ foiReferencesAtPoint file pos (FOIReferences asts) = case HM.lookup file asts of Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> - let posFile = fromMaybe pos $ fromCurrentPosition mapping pos - names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + let names = getNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where @@ -97,9 +99,17 @@ foiReferencesAtPoint file pos (FOIReferences asts) = $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) $ concat $ mapMaybe (`M.lookup` tr) names - toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) +getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] +getNamesAtPoint hf pos mapping = + let posFile = fromMaybe pos $ fromCurrentPosition mapping pos + in concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + +toCurrentLocation :: PositionMapping -> Location -> Maybe Location +toCurrentLocation mapping (Location uri range) = + Location uri <$> toCurrentRange mapping range + referencesAtPoint :: MonadIO m => HieDb diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 580031038e..d4515223a7 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -24,9 +24,13 @@ library , lsp-types , lsp , hls-plugin-api ^>=1.1 - , ghcide >=1.2 && <1.4 + , ghcide >=1.3.0.1 , text , unordered-containers + , extra + , containers + , hiedb + , ghc default-language: Haskell2010 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index cf16679cde..e9ffad9a14 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,17 +1,31 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} module Ide.Plugin.Rename (descriptor) where -import Data.Function -import Data.HashMap.Internal hiding (map) -import Data.List -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.LSP.HoverDefinition +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Bifunctor +import Data.HashMap.Internal (fromList) +import qualified Data.HashMap.Strict as HM +import Data.List.Extra +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Debug.Trace +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.Spans.AtPoint +import HieDb import Ide.Types import Language.LSP.Server import Language.LSP.Types +import Name + +type HiePosMap = HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping) descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { @@ -19,24 +33,66 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { } renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state _pluginId (RenameParams tdi pos _progToken name) = do - locs <- getTextEdits state tdi pos name - return $ Right (WorkspaceEdit { - _changes = Just (fromList locs), +renameProvider state _pluginId (RenameParams tdi pos _progToken newName) = do + edits <- liftIO $ renameEdits state tdi pos newName + pure $ Right (WorkspaceEdit { + _changes = Just (fromList edits), _documentChanges = Nothing, _changeAnnotations = Nothing }) -getTextEdits :: IdeState +renameEdits :: IdeState -> TextDocumentIdentifier -> Position -> T.Text - -> LspT c IO [(Uri, List TextEdit)] -getTextEdits state tdi pos name = do - mbLocs <- references state $ ReferenceParams tdi pos Nothing Nothing (ReferenceContext False) - case mbLocs of - Right (List locs) - -> return - $ map ((\(uri':_,tes) -> (uri', List tes)) . unzip) - $ groupBy ((==) `on` fst) [(uri, TextEdit range name) | Location uri range <- locs] - _ -> return [] + -> IO [(Uri, List TextEdit)] +renameEdits state tdi pos newName = do + List locs <- runNameRefs state $ ReferenceParams tdi pos Nothing Nothing (ReferenceContext False) + pure $ map (Data.Bifunctor.second List) + $ groupSort [(uri, TextEdit range newName) | Location uri range <- locs] + +runNameRefs :: IdeState -> ReferenceParams -> IO (List Location) +runNameRefs ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = + case uriToFilePath' uri of + Just fp -> List <$> runAction "Rename.references" ide (refsAtPoint (toNormalizedFilePath' fp) pos) + Nothing -> pure $ List [] + +-- some code duplication with AtPoint could be removed +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint nfp pos = do + ShakeExtras{hiedb} <- getShakeExtras + fois <- HM.keys <$> getFilesOfInterest + asts <- HM.fromList . mapMaybe sequence . zip fois <$> usesWithStale GetHieAst fois + case nameAtPoint asts pos nfp of + Nothing -> pure [] + Just name -> refsAtName asts name hiedb + +nameAtPoint :: HiePosMap -> Position -> NormalizedFilePath -> Maybe Name +nameAtPoint asts pos nfp = name =<< HM.lookup nfp asts + where name (HAR _ ast _ _ _, mapping) = listToMaybe $ getNamesAtPoint ast pos mapping + +-- remove HM.keys O(n) by passing foiRefs +refsAtName :: HiePosMap -> Name -> HieDb -> Action [Location] +refsAtName asts name hiedb = do + let foiRefs = concat $ mapMaybe (getNameAstLocations name) (HM.elems asts) + refs <- nameDbRefs (HM.keys asts) name hiedb + pure $ nubOrd $ map (updateLocLength (length $ getOccString name)) $ foiRefs ++ refs + +nameDbRefs :: [NormalizedFilePath] -> Name -> HieDb -> Action [Location] +nameDbRefs fois name hiedb = + case nameModule_maybe name of + Nothing -> pure [] + Just mod -> do + let exclude = map fromNormalizedFilePath fois + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe rowToLoc rows + +getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] +getNameAstLocations name (HAR _ _ rm _ _, mapping) = + mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm + +-- sets location length to n (keeping rightmost position the same) +-- Useful to drop module ID prefix from qualified name +updateLocLength :: Int -> Location -> Location +updateLocLength n (Location uri (Range (Position ln _) end@(Position _ col))) = + Location uri (Range (Position ln (col - n)) end) diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 1a843c69c3..882359eb12 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Ide.Plugin.Rename as Rename +import qualified Ide.Plugin.Rename as Rename import System.FilePath import Test.Hls @@ -17,21 +17,18 @@ tests = testGroup "rename" rename doc (Position 3 1) "baz" -- foo :: Int -> Int , goldenWithRename "function argument" "FunctionArgument" $ \doc -> do rename doc (Position 3 4) "y" -- foo x = x + 1 - , ignoreTestBecause "not yet implemented" $ - goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do - rename doc (Position 3 24) "baz" -- bar = FunctionArgument.foo + , goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do + rename doc (Position 3 24) "baz" -- bar = FunctionArgument.foo , goldenWithRename "record field" "RecordField" $ \doc -> do rename doc (Position 6 9) "number" -- foo Bam {n = y} = Bam {n = y + 5, s = ""} , goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do rename doc (Position 3 8) "y" -- x = 20 - , ignoreTestBecause "not yet implemented" $ - goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do - rename doc (Position 2 15) "BinaryTree" -- rotateRight :: Tree a -> Tree a + , goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do + rename doc (Position 2 15) "BinaryTree" -- rotateRight :: Tree a -> Tree a , goldenWithRename "data constructor" "DataConstructor" $ \doc -> do rename doc (Position 0 13) "Apply" -- data Expr = Op Int Int - , ignoreTestBecause "not yet implemented" $ - goldenWithRename "type variable" "TypeVariable" $ \doc -> do - rename doc (Position 0 13) "b" -- bar :: Maybe b -> Maybe b + , goldenWithRename "type variable" "TypeVariable" $ \doc -> do + rename doc (Position 0 13) "b" -- bar :: Maybe a -> Maybe a , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do rename doc (Position 0 35) "baz" -- import FunctionArgument (foo) ] diff --git a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs index 6ee982bdbe..0c46ffa077 100644 --- a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs +++ b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.expected.hs @@ -2,3 +2,4 @@ data BinaryTree a = Node a (BinaryTree a) (BinaryTree a) | Leaf a rotateRight :: BinaryTree a -> BinaryTree a rotateRight (Node v (Node v' l' r') r) = Node v' l' (Node v r' r) +rotateRight t = t diff --git a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs index b9593a31ce..4e728aa1a4 100644 --- a/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs +++ b/plugins/hls-rename-plugin/test/testdata/TypeConstructor.hs @@ -2,3 +2,4 @@ data Tree a = Node a (Tree a) (Tree a) | Leaf a rotateRight :: Tree a -> Tree a rotateRight (Node v (Node v' l' r') r) = Node v' l' (Node v r' r) +rotateRight t = t From 50588019681644eeb129829c3cdd51fa487f2f95 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 31 May 2021 21:41:23 +0100 Subject: [PATCH 06/49] GADT test case --- plugins/hls-rename-plugin/test/Main.hs | 2 ++ .../test/testdata/Gadt.expected.hs | 17 +++++++++++++++++ plugins/hls-rename-plugin/test/testdata/Gadt.hs | 17 +++++++++++++++++ 3 files changed, 36 insertions(+) create mode 100644 plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/Gadt.hs diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 882359eb12..bef358199b 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -31,6 +31,8 @@ tests = testGroup "rename" rename doc (Position 0 13) "b" -- bar :: Maybe a -> Maybe a , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do rename doc (Position 0 35) "baz" -- import FunctionArgument (foo) + , goldenWithRename "GADT" "Gadt" $ \doc -> do + rename doc (Position 6 35) "Expr" -- Even :: Expression Int -> Expression Bool ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree diff --git a/plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs b/plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs new file mode 100644 index 0000000000..65115d42d7 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Gadt.expected.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} + +data Expr a where + Number :: Int -> Expr Int + Boolean :: Bool -> Expr Bool + Not :: Expr Bool -> Expr Bool + Even :: Expr Int -> Expr Bool + Add :: Enum a => Expr a -> Expr a -> Expr Int + Max :: Ord a => Expr a -> Expr a -> Expr a + +evaluate :: Expr a -> a +evaluate (Number n) = n +evaluate (Boolean p) = p +evaluate (Add n m) = fromEnum (evaluate n) + fromEnum (evaluate m) +evaluate (Even n) = even $ evaluate n +evaluate (Not p) = not $ evaluate p +evaluate (Max x y) = max (evaluate x) (evaluate y) diff --git a/plugins/hls-rename-plugin/test/testdata/Gadt.hs b/plugins/hls-rename-plugin/test/testdata/Gadt.hs new file mode 100644 index 0000000000..408f516900 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Gadt.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} + +data Expression a where + Number :: Int -> Expression Int + Boolean :: Bool -> Expression Bool + Not :: Expression Bool -> Expression Bool + Even :: Expression Int -> Expression Bool + Add :: Enum a => Expression a -> Expression a -> Expression Int + Max :: Ord a => Expression a -> Expression a -> Expression a + +evaluate :: Expression a -> a +evaluate (Number n) = n +evaluate (Boolean p) = p +evaluate (Add n m) = fromEnum (evaluate n) + fromEnum (evaluate m) +evaluate (Even n) = even $ evaluate n +evaluate (Not p) = not $ evaluate p +evaluate (Max x y) = max (evaluate x) (evaluate y) From fc65cbfccc34d03e3e78f22c33d4d2f3cbeb2ebb Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 8 Jul 2021 11:46:04 +0100 Subject: [PATCH 07/49] Initial integration with retrie --- .../Development/IDE/LSP/HoverDefinition.hs | 1 + ghcide/src/Development/IDE/Spans/AtPoint.hs | 2 - .../hls-rename-plugin/hls-rename-plugin.cabal | 6 +- .../src/Ide/Plugin/Rename.hs | 102 +++++++----------- .../test/testdata/DataConstructor.expected.hs | 4 +- .../src/Ide/Plugin/Retrie.hs | 11 +- 6 files changed, 51 insertions(+), 75 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 97a5a3e065..b82be1cf9b 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -10,6 +10,7 @@ module Development.IDE.LSP.HoverDefinition , hover , gotoDefinition , gotoTypeDefinition + , references ) where import Control.Monad.IO.Class diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 5f56bc78cf..33b2e760af 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -16,9 +16,7 @@ module Development.IDE.Spans.AtPoint ( , computeTypeReferences , FOIReferences(..) , defRowToSymbolInfo - , rowToLoc , getNamesAtPoint - , toCurrentLocation ) where import Development.IDE.GHC.Error diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index d4515223a7..d944eb9289 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -20,16 +20,18 @@ library exposed-modules: Ide.Plugin.Rename hs-source-dirs: src build-depends: + , aeson , base >=4.12 && <5 , lsp-types , lsp , hls-plugin-api ^>=1.1 , ghcide >=1.3.0.1 + , retrie >=0.1.1.0 + , transformers + , hls-retrie-plugin , text , unordered-containers - , extra , containers - , hiedb , ghc default-language: Haskell2010 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index e9ffad9a14..bc033b8bdc 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Rename (descriptor) where -import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Class import qualified Data.Bifunctor +import Data.Either import Data.HashMap.Internal (fromList) import qualified Data.HashMap.Strict as HM -import Data.List.Extra import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T -import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake import Development.IDE.GHC.Compat +import Development.IDE.LSP.HoverDefinition (references) import Development.IDE.Spans.AtPoint -import HieDb +import Ide.Plugin.Retrie hiding (descriptor) import Ide.Types -import Language.LSP.Server import Language.LSP.Types import Name +import Retrie +import Data.Char type HiePosMap = HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping) @@ -33,66 +34,35 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { } renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state _pluginId (RenameParams tdi pos _progToken newName) = do - edits <- liftIO $ renameEdits state tdi pos newName - pure $ Right (WorkspaceEdit { - _changes = Just (fromList edits), - _documentChanges = Nothing, - _changeAnnotations = Nothing - }) +renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newName) = response $ do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) + oldName <- liftIO $ getOccString <$> runAction "Rename.nameAtPos" state (nameAtPos pos nfp) + mRefs <- lift $ references state (ReferenceParams tdi pos Nothing Nothing (ReferenceContext False)) + let isType = isUpper $ head oldName + rewrite = (if isType then AdhocType else Adhoc) (oldName ++ " = " ++ T.unpack newName) + List refs = fromRight (List []) mRefs + (_errors, edits) <- liftIO $ + callRetrie + state + (hscEnv $ fst $ fromJust session) + [Right rewrite] + nfp + True + (Just $ isReference refs) + return edits -renameEdits :: IdeState - -> TextDocumentIdentifier - -> Position - -> T.Text - -> IO [(Uri, List TextEdit)] -renameEdits state tdi pos newName = do - List locs <- runNameRefs state $ ReferenceParams tdi pos Nothing Nothing (ReferenceContext False) - pure $ map (Data.Bifunctor.second List) - $ groupSort [(uri, TextEdit range newName) | Location uri range <- locs] +isReference :: [Location] -> MatchResultTransformer +isReference refs _ctxt match + | MatchResult substitution template <- match + , Just loc <- srcSpanToLocation $ getOrigin $ astA $ tTemplate template -- Bug: incorrect loc + , loc `elem` refs = return match + | otherwise = return NoMatch -runNameRefs :: IdeState -> ReferenceParams -> IO (List Location) -runNameRefs ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = - case uriToFilePath' uri of - Just fp -> List <$> runAction "Rename.references" ide (refsAtPoint (toNormalizedFilePath' fp) pos) - Nothing -> pure $ List [] - --- some code duplication with AtPoint could be removed -refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] -refsAtPoint nfp pos = do +nameAtPos :: Position -> NormalizedFilePath -> Action Name +nameAtPos pos nfp = do ShakeExtras{hiedb} <- getShakeExtras fois <- HM.keys <$> getFilesOfInterest asts <- HM.fromList . mapMaybe sequence . zip fois <$> usesWithStale GetHieAst fois - case nameAtPoint asts pos nfp of - Nothing -> pure [] - Just name -> refsAtName asts name hiedb - -nameAtPoint :: HiePosMap -> Position -> NormalizedFilePath -> Maybe Name -nameAtPoint asts pos nfp = name =<< HM.lookup nfp asts - where name (HAR _ ast _ _ _, mapping) = listToMaybe $ getNamesAtPoint ast pos mapping - --- remove HM.keys O(n) by passing foiRefs -refsAtName :: HiePosMap -> Name -> HieDb -> Action [Location] -refsAtName asts name hiedb = do - let foiRefs = concat $ mapMaybe (getNameAstLocations name) (HM.elems asts) - refs <- nameDbRefs (HM.keys asts) name hiedb - pure $ nubOrd $ map (updateLocLength (length $ getOccString name)) $ foiRefs ++ refs - -nameDbRefs :: [NormalizedFilePath] -> Name -> HieDb -> Action [Location] -nameDbRefs fois name hiedb = - case nameModule_maybe name of - Nothing -> pure [] - Just mod -> do - let exclude = map fromNormalizedFilePath fois - rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude - pure $ mapMaybe rowToLoc rows - -getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] -getNameAstLocations name (HAR _ _ rm _ _, mapping) = - mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm - --- sets location length to n (keeping rightmost position the same) --- Useful to drop module ID prefix from qualified name -updateLocLength :: Int -> Location -> Location -updateLocLength n (Location uri (Range (Position ln _) end@(Position _ col))) = - Location uri (Range (Position ln (col - n)) end) + let getName (HAR _ ast _ _ _, mapping) = listToMaybe $ getNamesAtPoint ast pos mapping + return $ fromJust $ getName (fromJust $ HM.lookup nfp asts) diff --git a/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs b/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs index b614d72291..d1ee10a6d1 100644 --- a/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs +++ b/plugins/hls-rename-plugin/test/testdata/DataConstructor.expected.hs @@ -1,4 +1,4 @@ -data Expr = Apply Int Int +data Expr = Op Int Int plus :: Expr -> Expr -plus (Apply n m) = Apply (n + m) 0 +plus (Op n m) = Op (n + m) 0 diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 0414c7deb8..8d6442ce7d 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -13,7 +13,7 @@ {-# OPTIONS -Wno-orphans #-} -module Ide.Plugin.Retrie (descriptor) where +module Ide.Plugin.Retrie (descriptor, callRetrie, RunRetrieParams(..), response) where import Control.Concurrent.Extra (readVar) import Control.Exception.Safe (Exception (..), @@ -41,6 +41,7 @@ import Data.Hashable (unhashed) import Data.IORef.Extra (atomicModifyIORef'_, newIORef, readIORef) import Data.List.Extra (find, nubOrdOn) +import Data.Maybe (fromMaybe) import Data.String (IsString (fromString)) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -98,6 +99,7 @@ import Retrie.Replace (Change (..), Replacement (..)) import Retrie.Rewrites import Retrie.SYB (listify) +import Retrie.Types (setRewriteTransformer, MatchResultTransformer, defaultTransformer) import Retrie.Util (Verbosity (Loud)) import StringBuffer (stringToStringBuffer) import System.Directory (makeAbsolute) @@ -145,6 +147,7 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = (map Right rewrites <> map Left importRewrites) nfp restrictToOriginatingFile + Nothing unless (null errors) $ lift $ sendNotification SWindowShowMessage $ ShowMessageParams MtWarning $ @@ -347,8 +350,9 @@ callRetrie :: [Either ImportSpec RewriteSpec] -> NormalizedFilePath -> Bool -> + Maybe MatchResultTransformer -> IO ([CallRetrieError], WorkspaceEdit) -callRetrie state session rewrites origin restrictToOriginatingFile = do +callRetrie state session rewrites origin restrictToOriginatingFile mbTransformer = do knownFiles <- toKnownFiles . unhashed <$> readVar (knownTargetsVar $ shakeExtras state) let reuseParsedModule f = do pm <- @@ -410,8 +414,9 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0 (originFixities, originParsedModule) <- reuseParsedModule origin + let transformer = fromMaybe defaultTransformer mbTransformer retrie <- - (\specs -> apply specs >> addImports annotatedImports) + (\specs -> apply (map (setRewriteTransformer transformer) specs) >> addImports annotatedImports) <$> parseRewriteSpecs (\_f -> return $ NoCPP originParsedModule) originFixities From 90ff9ba5db001e00ffb65308f59886b1f2e91a35 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 8 Jul 2021 11:53:26 +0100 Subject: [PATCH 08/49] updated session to use getCompilerOptions --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c266147e99..1a37248748 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -88,6 +88,7 @@ import HieDb.Create import HieDb.Types import HieDb.Utils import Ide.Types (dynFlagsModifyGlobal) +import HIE.Bios (getCompilerOptions) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -505,9 +506,8 @@ cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) cradleToOptsAndLibDir cradle file = do -- Start off by getting the session options - let showLine s = hPutStrLn stderr ("> " ++ s) hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle - cradleRes <- runCradle (cradleOptsProg cradle) showLine file + cradleRes <- getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir From 67a7bc52ce1f13d95b2797cf979091c42cdede74 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Fri, 9 Jul 2021 13:47:43 +0100 Subject: [PATCH 09/49] use custom context updater --- .../Development/IDE/LSP/HoverDefinition.hs | 1 - .../src/Ide/Plugin/Rename.hs | 55 +++++++++++++------ .../src/Ide/Plugin/Retrie.hs | 37 +++++++++---- 3 files changed, 64 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index b82be1cf9b..97a5a3e065 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -10,7 +10,6 @@ module Development.IDE.LSP.HoverDefinition , hover , gotoDefinition , gotoTypeDefinition - , references ) where import Control.Monad.IO.Class diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index bc033b8bdc..12046621ae 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,30 +1,33 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Rename (descriptor) where import Control.Monad.IO.Class import Control.Monad.Trans.Class import qualified Data.Bifunctor +import Data.Char import Data.Either import Data.HashMap.Internal (fromList) import qualified Data.HashMap.Strict as HM +import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.Actions (refsAtPoint) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake import Development.IDE.GHC.Compat -import Development.IDE.LSP.HoverDefinition (references) import Development.IDE.Spans.AtPoint import Ide.Plugin.Retrie hiding (descriptor) import Ide.Types import Language.LSP.Types import Name import Retrie -import Data.Char +import Control.Monad.Trans.Maybe type HiePosMap = HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping) @@ -37,19 +40,22 @@ renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newName) = response $ do let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) - oldName <- liftIO $ getOccString <$> runAction "Rename.nameAtPos" state (nameAtPos pos nfp) - mRefs <- lift $ references state (ReferenceParams tdi pos Nothing Nothing (ReferenceContext False)) - let isType = isUpper $ head oldName - rewrite = (if isType then AdhocType else Adhoc) (oldName ++ " = " ++ T.unpack newName) - List refs = fromRight (List []) mRefs + oldName <- liftIO $ runAction "Rename.nameAtPos" state (nameAtPos pos nfp) + refs <- liftIO $ runAction "Rename.refsAtPoint" state $ refsAtPoint nfp pos + + let emptyContextUpdater c i = const (return c) + isType = isUpper $ head oldNameStr + oldNameStr = getOccString oldName + rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newName) (_errors, edits) <- liftIO $ - callRetrie - state - (hscEnv $ fst $ fromJust session) - [Right rewrite] - nfp - True - (Just $ isReference refs) + callRetrieWithTransformerAndUpdates + (isReference refs) + emptyContextUpdater + state + (hscEnv $ fst $ fromJust session) + [Right rewrite] + nfp + True return edits isReference :: [Location] -> MatchResultTransformer @@ -62,7 +68,20 @@ isReference refs _ctxt match nameAtPos :: Position -> NormalizedFilePath -> Action Name nameAtPos pos nfp = do ShakeExtras{hiedb} <- getShakeExtras - fois <- HM.keys <$> getFilesOfInterest - asts <- HM.fromList . mapMaybe sequence . zip fois <$> usesWithStale GetHieAst fois - let getName (HAR _ ast _ _ _, mapping) = listToMaybe $ getNamesAtPoint ast pos mapping - return $ fromJust $ getName (fromJust $ HM.lookup nfp asts) + Just (HAR _ asts _ _ _, mapping) <- head <$> usesWithStale GetHieAst [nfp] + return $ head $ getNamesAtPoint asts pos mapping + +------ Debugging +showAstNode :: Int -> HieAST a -> [Char] +showAstNode n ast = + intercalate indentation [ + "Ast Span: " ++ show (nodeSpan ast), + "Info: " ++ show (map showName (M.keys (nodeIdentifiers (nodeInfo ast)))), + "Children: " ++ concatMap (showAstNode (succ n)) (nodeChildren ast) + ] + where indentation = '\n' : replicate (n * 4) ' ' + +showName :: NamedThing a => Either ModuleName a -> String +showName (Left mn) = moduleNameString mn +showName (Right n) = getOccString n +------ diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 8d6442ce7d..7e28acfe14 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -12,8 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE RankNTypes #-} -module Ide.Plugin.Retrie (descriptor, callRetrie, RunRetrieParams(..), response) where +module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, RunRetrieParams(..), response) where import Control.Concurrent.Extra (readVar) import Control.Exception.Safe (Exception (..), @@ -46,12 +47,12 @@ import Data.String (IsString (fromString)) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable (Typeable) +import Debug.Trace (trace) import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake (ShakeExtras (knownTargetsVar), toKnownFiles) import Development.IDE.GHC.Compat (GenLocated (L), GhcRn, - HsBindLR (FunBind), HsGroup (..), HsValBindsLR (..), HscEnv, IdP, LRuleDecls, @@ -76,6 +77,7 @@ import GhcPlugins (Outputable, nameRdrName, occNameFS, occNameString, rdrNameOcc, unpackFS) +import HsBinds import Ide.PluginUtils import Ide.Types import Language.LSP.Server (LspM, @@ -85,11 +87,13 @@ import Language.LSP.Server (LspM, withIndefiniteProgress) import Language.LSP.Types as J import Retrie.CPP (CPP (NoCPP), parseCPP) +import Retrie.Context (ContextUpdater, updateContext) import Retrie.ExactPrint (fix, relativiseApiAnns, transformA, unsafeMkA) import Retrie.Fixity (mkFixityEnv) import qualified Retrie.GHC as GHC -import Retrie.Monad (addImports, apply, +import Retrie.Monad (addImports, + applyWithUpdate, getGroundTerms, runRetrie) import Retrie.Options (defaultOptions, @@ -99,7 +103,9 @@ import Retrie.Replace (Change (..), Replacement (..)) import Retrie.Rewrites import Retrie.SYB (listify) -import Retrie.Types (setRewriteTransformer, MatchResultTransformer, defaultTransformer) +import Retrie.Types (MatchResultTransformer, + defaultTransformer, + setRewriteTransformer) import Retrie.Util (Verbosity (Loud)) import StringBuffer (stringToStringBuffer) import System.Directory (makeAbsolute) @@ -147,7 +153,6 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = (map Right rewrites <> map Left importRewrites) nfp restrictToOriginatingFile - Nothing unless (null errors) $ lift $ sendNotification SWindowShowMessage $ ShowMessageParams MtWarning $ @@ -350,9 +355,22 @@ callRetrie :: [Either ImportSpec RewriteSpec] -> NormalizedFilePath -> Bool -> - Maybe MatchResultTransformer -> IO ([CallRetrieError], WorkspaceEdit) -callRetrie state session rewrites origin restrictToOriginatingFile mbTransformer = do +callRetrie = + callRetrieWithTransformerAndUpdates defaultTransformer updateContext + +-- allows custom 'ContextUpdater' to be given to 'applyWithUpdates' +-- applies transformations to the spec +callRetrieWithTransformerAndUpdates :: + MatchResultTransformer -> + ContextUpdater -> + IdeState -> + HscEnv -> + [Either ImportSpec RewriteSpec] -> + NormalizedFilePath -> + Bool -> + IO ([CallRetrieError], WorkspaceEdit) +callRetrieWithTransformerAndUpdates transformer contextUpdater state session rewrites origin restrictToOriginatingFile = do knownFiles <- toKnownFiles . unhashed <$> readVar (knownTargetsVar $ shakeExtras state) let reuseParsedModule f = do pm <- @@ -414,9 +432,8 @@ callRetrie state session rewrites origin restrictToOriginatingFile mbTransformer unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0 (originFixities, originParsedModule) <- reuseParsedModule origin - let transformer = fromMaybe defaultTransformer mbTransformer - retrie <- - (\specs -> apply (map (setRewriteTransformer transformer) specs) >> addImports annotatedImports) + retrie <- do (\specs -> applyWithUpdate updateContext (map (setRewriteTransformer transformer) specs) + >> addImports annotatedImports) <$> parseRewriteSpecs (\_f -> return $ NoCPP originParsedModule) originFixities From 57f8c08074a8cb9e89ac9c3d321bbd41b8a62f5d Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 19 Jul 2021 13:15:32 +0100 Subject: [PATCH 10/49] Use direct reference locations --- ghcide/ghcide.cabal | 2 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 2 + .../hls-rename-plugin/hls-rename-plugin.cabal | 1 + .../src/Ide/Plugin/Rename.hs | 68 ++++++++++++------- .../hls-rename-plugin/test/testdata/hie.yaml | 1 + 5 files changed, 50 insertions(+), 24 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 7520e94a34..73297f1208 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -98,7 +98,7 @@ library ghc-check >=0.5.0.1, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios >= 0.7.1 && < 0.8.0, + hie-bios >= 0.7.1 && < 0.9.0, implicit-hie-cradle >= 0.3.0.2 && < 0.4, base16-bytestring >=0.1.1 && <1.1 if os(windows) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 33b2e760af..09834053cb 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -17,6 +17,8 @@ module Development.IDE.Spans.AtPoint ( , FOIReferences(..) , defRowToSymbolInfo , getNamesAtPoint + , toCurrentLocation + , rowToLoc ) where import Development.IDE.GHC.Error diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index d944eb9289..9d079a5f57 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -33,6 +33,7 @@ library , unordered-containers , containers , ghc + , hiedb default-language: Haskell2010 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 12046621ae..449a34d95f 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,33 +1,35 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Rename (descriptor) where import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe import qualified Data.Bifunctor import Data.Char -import Data.Either +import Data.Containers.ListUtils import Data.HashMap.Internal (fromList) import qualified Data.HashMap.Strict as HM -import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.Actions (refsAtPoint) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Spans.AtPoint +import HieDb.Query import Ide.Plugin.Retrie hiding (descriptor) import Ide.Types import Language.LSP.Types import Name import Retrie -import Control.Monad.Trans.Maybe +import Retrie.ExactPrint +import Retrie.Universe type HiePosMap = HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping) @@ -41,15 +43,16 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) oldName <- liftIO $ runAction "Rename.nameAtPos" state (nameAtPos pos nfp) - refs <- liftIO $ runAction "Rename.refsAtPoint" state $ refsAtPoint nfp pos + refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) let emptyContextUpdater c i = const (return c) isType = isUpper $ head oldNameStr oldNameStr = getOccString oldName + -- rewrite = Unfold "Main.foo" rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newName) (_errors, edits) <- liftIO $ callRetrieWithTransformerAndUpdates - (isReference refs) + (referenceTransformer refs) emptyContextUpdater state (hscEnv $ fst $ fromJust session) @@ -58,30 +61,49 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos True return edits -isReference :: [Location] -> MatchResultTransformer -isReference refs _ctxt match - | MatchResult substitution template <- match +referenceTransformer :: [Location] -> MatchResultTransformer +referenceTransformer refs _ctxt match + | MatchResult _substitution template <- match , Just loc <- srcSpanToLocation $ getOrigin $ astA $ tTemplate template -- Bug: incorrect loc , loc `elem` refs = return match | otherwise = return NoMatch nameAtPos :: Position -> NormalizedFilePath -> Action Name nameAtPos pos nfp = do - ShakeExtras{hiedb} <- getShakeExtras Just (HAR _ asts _ _ _, mapping) <- head <$> usesWithStale GetHieAst [nfp] return $ head $ getNamesAtPoint asts pos mapping ------- Debugging -showAstNode :: Int -> HieAST a -> [Char] -showAstNode n ast = - intercalate indentation [ - "Ast Span: " ++ show (nodeSpan ast), - "Info: " ++ show (map showName (M.keys (nodeIdentifiers (nodeInfo ast)))), - "Children: " ++ concatMap (showAstNode (succ n)) (nodeChildren ast) - ] - where indentation = '\n' : replicate (n * 4) ' ' +refsAtName :: NormalizedFilePath -> Name -> Action [Location] +refsAtName nfp name = do + ShakeExtras{hiedb} <- getShakeExtras + fois <- HM.keys <$> getFilesOfInterest + asts <- HM.fromList . mapMaybe sequence . zip fois <$> usesWithStale GetHieAst fois + let foiRefs = concat $ mapMaybe (getNameAstLocations name) (HM.elems asts) + refs <- nameDbRefs (HM.keys asts) name hiedb + pure $ nubOrd $ foiRefs ++ refs + +nameDbRefs :: [NormalizedFilePath] -> Name -> HieDb -> Action [Location] +nameDbRefs fois name hiedb = + case nameModule_maybe name of + Nothing -> pure [] + Just mod -> do + let exclude = map fromNormalizedFilePath fois + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe rowToLoc rows + +getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] +getNameAstLocations name (HAR _ _ rm _ _, mapping) = + mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm + +-- Debugging +showMatch :: MatchResult Universe -> [Char] +showMatch NoMatch = "Nomatch" +showMatch (MatchResult sub temp) = + "Sub: " ++ show sub ++ + " \ntemp: " ++ showTemp (astA $ tTemplate temp) ++ + " \nAnns: " ++ show (annsA (tTemplate temp)) -showName :: NamedThing a => Either ModuleName a -> String -showName (Left mn) = moduleNameString mn -showName (Right n) = getOccString n ------- +showTemp (ULHsExpr _) = "ULHsExpr" +showTemp (ULStmt _) = "ULStmt" +showTemp (ULType _) = "ULType" +showTemp (ULPat _) = "ULPat" diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml index 4d89779b67..d18faf0a8e 100644 --- a/plugins/hls-rename-plugin/test/testdata/hie.yaml +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -10,3 +10,4 @@ cradle: - "TypeVariable" - "TypeConstructor" - "DataConstructor" + - "Gadt" From ff170559cc3c322cf4427559753b1e210fc7bef0 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 19 Jul 2021 22:35:18 +0100 Subject: [PATCH 11/49] add rename plugin to 9.0.1 yaml --- cabal-ghc901.project | 1 + ghcide/ghcide.cabal | 2 +- plugins/hls-rename-plugin/hls-rename-plugin.cabal | 6 +++--- plugins/hls-retrie-plugin/hls-retrie-plugin.cabal | 2 +- stack-9.0.1.yaml | 1 + 5 files changed, 7 insertions(+), 5 deletions(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 966fbf63ee..6fdf34bd8d 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -15,6 +15,7 @@ packages: ./plugins/hls-explicit-imports-plugin ./plugins/hls-refine-imports-plugin ./plugins/hls-hlint-plugin + ./plugins/hls-rename-plugin ./plugins/hls-retrie-plugin ./plugins/hls-haddock-comments-plugin -- ./plugins/hls-splice-plugin diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0d4f4b259d..342eca6ed6 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 build-type: Simple category: Development name: ghcide -version: 1.4.0.3 +version: 1.4.0.4 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 9d079a5f57..d27a7221a4 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -25,10 +25,10 @@ library , lsp-types , lsp , hls-plugin-api ^>=1.1 - , ghcide >=1.3.0.1 - , retrie >=0.1.1.0 + , ghcide >=1.4.0.4 + , retrie >=0.1.1.1 , transformers - , hls-retrie-plugin + , hls-retrie-plugin >= 1.0.1.1 , text , unordered-containers , containers diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 61b24373ff..e6f90b3a93 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-retrie-plugin -version: 1.0.1.0 +version: 1.0.1.1 synopsis: Retrie integration plugin for Haskell Language Server license: Apache-2.0 license-file: LICENSE diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index eea9bbed2b..e9038f8ff3 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -15,6 +15,7 @@ packages: - ./plugins/hls-explicit-imports-plugin # - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin + - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin # - ./plugins/hls-splice-plugin # - ./plugins/hls-tactics-plugin From 112dd6cd02cc1048846fd35535ad5d134922cb6d Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 20 Jul 2021 01:02:01 +0100 Subject: [PATCH 12/49] bump retrie build-depend --- .../hls-rename-plugin/hls-rename-plugin.cabal | 2 +- .../src/Ide/Plugin/Rename.hs | 21 +++++++++---------- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index d27a7221a4..cf6ceee94f 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -26,7 +26,7 @@ library , lsp , hls-plugin-api ^>=1.1 , ghcide >=1.4.0.4 - , retrie >=0.1.1.1 + , retrie >0.1.1.1 , transformers , hls-retrie-plugin >= 1.0.1.1 , text diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 25ded010dd..5fc34def47 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Rename (descriptor) where @@ -8,7 +9,6 @@ import Control.Monad.IO.Class import qualified Data.Bifunctor import Data.Char import Data.Containers.ListUtils -import Data.HashMap.Internal (fromList) import qualified Data.HashMap.Strict as HM import qualified Data.Map as M import Data.Maybe @@ -25,8 +25,7 @@ import Ide.Types import Language.LSP.Types import Name import Retrie - -type HiePosMap = HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping) +import Debug.Trace (trace) descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { @@ -43,7 +42,7 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos let emptyContextUpdater c i = const (return c) isType = isUpper $ head oldNameStr oldNameStr = getOccString oldName - -- rewrite = Unfold "Main.foo" + -- rewrite = Unfold "Main.foo" rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newName) (_errors, edits) <- liftIO $ callRetrieWithTransformerAndUpdates @@ -58,7 +57,7 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match - | MatchResult _substitution template <- match + | MatchResult _sub template <- match , Just loc <- srcSpanToLocation $ getOrigin $ astA $ tTemplate template -- Bug: incorrect loc , loc `elem` refs = return match | otherwise = return NoMatch @@ -72,9 +71,9 @@ refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do ShakeExtras{hiedb} <- getShakeExtras fois <- HM.keys <$> getFilesOfInterestUntracked - asts <- HM.fromList . mapMaybe sequence . zip fois <$> usesWithStale GetHieAst fois - let foiRefs = concat $ mapMaybe (getNameAstLocations name) (HM.elems asts) - refs <- nameDbRefs (HM.keys asts) name hiedb + Just asts <- sequence <$> usesWithStale GetHieAst fois + let foiRefs = concat $ mapMaybe (getNameAstLocations name) asts + refs <- nameDbRefs fois name hiedb pure $ nubOrd $ foiRefs ++ refs nameDbRefs :: [NormalizedFilePath] -> Name -> HieDb -> Action [Location] From 5d854549f0090301938b9831675a3708ff6710a9 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 20 Jul 2021 17:31:17 +0100 Subject: [PATCH 13/49] bump retrie version in stack yamls --- haskell-language-server.cabal | 2 ++ stack-8.10.2.yaml | 2 +- stack-8.10.3.yaml | 2 +- stack-8.10.4.yaml | 2 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.3.yaml | 2 +- stack-8.8.4.yaml | 2 +- stack.yaml | 2 +- test/utils/Test/Hls/Flags.hs | 8 ++++++++ 10 files changed, 18 insertions(+), 8 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ffacd27997..6cbb183962 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -444,6 +444,8 @@ test-suite func-test cpp-options: -Deval if flag(importLens) || flag(all-plugins) cpp-options: -DimportLens + if flag(rename) || flag(all-plugins) + cpp-options: -Drename if flag(retrie) || flag(all-plugins) cpp-options: -Dretrie if flag(tactic) || flag(all-plugins) diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 1e33872116..799b7ae55c 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -54,7 +54,7 @@ extra-deps: - implicit-hie-0.1.2.6 - monad-dijkstra-0.1.1.2 - refinery-0.4.0.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - shake-0.19.4 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 796b9903d7..8e3d8afaff 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -51,7 +51,7 @@ extra-deps: - implicit-hie-0.1.2.6 - monad-dijkstra-0.1.1.2 - refinery-0.4.0.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - shake-0.19.4 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index f773268677..de8a852bda 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -48,7 +48,7 @@ extra-deps: - implicit-hie-0.1.2.6 - monad-dijkstra-0.1.1.2 - refinery-0.4.0.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index f652352e0e..f74bcb4b12 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -80,7 +80,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - semialign-1.1 - shake-0.19.4 - stylish-haskell-0.12.2.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 031192dd7f..597026feb0 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -81,7 +81,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - semialign-1.1 - shake-0.19.4 - stylish-haskell-0.12.2.0 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 83fe606bba..f5853786f0 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -64,7 +64,7 @@ extra-deps: - opentelemetry-extra-0.6.1 - ormolu-0.1.4.1 - refinery-0.4.0.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - semigroups-0.18.5 - shake-0.19.4 - stylish-haskell-0.12.2.0 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 64b2c3de02..eeb9c7ec70 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -63,7 +63,7 @@ extra-deps: - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 - refinery-0.4.0.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - semigroups-0.18.5 - shake-0.19.4 - stylish-haskell-0.12.2.0 diff --git a/stack.yaml b/stack.yaml index dd8f5abcd9..1998745f79 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,7 +45,7 @@ extra-deps: - implicit-hie-0.1.2.6 - monad-dijkstra-0.1.1.2 - refinery-0.4.0.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 diff --git a/test/utils/Test/Hls/Flags.hs b/test/utils/Test/Hls/Flags.hs index 84ff263f76..ce17c7568e 100644 --- a/test/utils/Test/Hls/Flags.hs +++ b/test/utils/Test/Hls/Flags.hs @@ -39,6 +39,14 @@ requiresImportLensPlugin = id requiresImportLensPlugin = ignoreTestBecause "ImportLens plugin disabled" #endif +-- | Disable test unless the rename flag is set +requiresRenamePlugin :: TestTree -> TestTree +#if rename +requiresRenamePlugin = id +#else +requiresRenamePlugin = ignoreTestBecause "Rename plugin disabled" +#endif + -- | Disable test unless the retrie flag is set requiresRetriePlugin :: TestTree -> TestTree #if retrie From 76f80d324e4a84c770535b0fe0da81a896f6d4ca Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 20 Jul 2021 19:22:27 +0100 Subject: [PATCH 14/49] use getNodeIds in AtPoint --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index b2f9688fe9..f02f9f7129 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -93,7 +93,10 @@ foiReferencesAtPoint file pos (FOIReferences asts) = case HM.lookup file asts of Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> - let names = getNamesAtPoint hf pos mapping + let names = let + posFile = fromMaybe pos $ fromCurrentPosition mapping pos + in + concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where @@ -105,8 +108,9 @@ foiReferencesAtPoint file pos (FOIReferences asts) = getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] getNamesAtPoint hf pos mapping = - let posFile = fromMaybe pos $ fromCurrentPosition mapping pos - in concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) + where + posFile = fromMaybe pos $ fromCurrentPosition mapping pos toCurrentLocation :: PositionMapping -> Location -> Maybe Location toCurrentLocation mapping (Location uri range) = From 99acac2e8f65aaf09f8121193d2a75911aa5acde Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 20 Jul 2021 21:18:24 +0100 Subject: [PATCH 15/49] indentation --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index f02f9f7129..52226967e2 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -93,10 +93,7 @@ foiReferencesAtPoint file pos (FOIReferences asts) = case HM.lookup file asts of Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> - let names = let - posFile = fromMaybe pos $ fromCurrentPosition mapping pos - in - concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) + let names = getNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where From 017aac3225441e6e97c628c585c6585058d48724 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 25 Jul 2021 15:25:06 +0100 Subject: [PATCH 16/49] groundwork for renaming declarations --- ghcide/test/exe/Main.hs | 2 +- .../hls-rename-plugin/hls-rename-plugin.cabal | 1 + .../src/Ide/Plugin/Rename.hs | 58 +++++++++++-------- 3 files changed, 37 insertions(+), 24 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 57dc1dc16f..40f3ddab5f 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -190,7 +190,7 @@ initializeResponseTests = withResource acquire release tests where _documentRangeFormattingProvider (Just $ InL False) , chk "NO doc formatting on typing" _documentOnTypeFormattingProvider Nothing - , chk " renaming" _renameProvider (Just $ InL False) + , chk "NO renaming" _renameProvider (Just $ InL False) , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index cf6ceee94f..bb0609a377 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -34,6 +34,7 @@ library , containers , ghc , hiedb + , ghc-exactprint default-language: Haskell2010 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 5fc34def47..1550dc4851 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Rename (descriptor) where import Control.Monad.IO.Class +import Control.Monad.Trans.Class import qualified Data.Bifunctor import Data.Char import Data.Containers.ListUtils @@ -14,37 +14,48 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) -import Development.IDE.Core.Actions (refsAtPoint) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.AtPoint import HieDb.Query import Ide.Plugin.Retrie hiding (descriptor) import Ide.Types -import Language.LSP.Types +import Language.Haskell.GHC.ExactPrint +import Language.LSP.Server +import Language.LSP.Types hiding (_changes) import Name -import Retrie -import Debug.Trace (trace) +import Retrie hiding (getLoc) +import Ide.PluginUtils descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { pluginHandlers = mkPluginHandler STextDocumentRename renameProvider } +-- Todo: handle errors correctly (remove fromJust) renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newName) = response $ do let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + + -- rename LHS declarations + (annPs, _) <- liftIO $ fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (useWithStale GetAnnotatedParsedSource nfp) -- stale? + ccs <- lift getClientCapabilities + let src = printA annPs + res = printA (fmap renameLhsDecls annPs) + declEdits = makeDiffTextEdit (T.pack src) (T.pack res) + + -- use retrie to rename right-hand sides + (HAR _ asts _ _ _, mapping) <- liftIO $ fromJust <$> runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) + let oldName = head $ getNamesAtPoint asts pos mapping session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) - oldName <- liftIO $ runAction "Rename.nameAtPos" state (nameAtPos pos nfp) refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) - let emptyContextUpdater c i = const (return c) isType = isUpper $ head oldNameStr oldNameStr = getOccString oldName - -- rewrite = Unfold "Main.foo" rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newName) - (_errors, edits) <- liftIO $ + (_errors, edits@WorkspaceEdit{_changes}) <- liftIO $ callRetrieWithTransformerAndUpdates (referenceTransformer refs) emptyContextUpdater @@ -53,31 +64,32 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos [Right rewrite] nfp True - return edits + + return (edits {_changes = HM.update (Just . (<> declEdits)) uri <$> _changes}) + +-- TODO: rename LHS of top level decl in parsedSource (using grafts?) +renameLhsDecls :: ParsedSource -> ParsedSource +renameLhsDecls = error "not implemented" referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match | MatchResult _sub template <- match , Just loc <- srcSpanToLocation $ getOrigin $ astA $ tTemplate template -- Bug: incorrect loc - , loc `elem` refs = return match + -- , loc `elem` refs + = return match | otherwise = return NoMatch -nameAtPos :: Position -> NormalizedFilePath -> Action Name -nameAtPos pos nfp = do - Just (HAR _ asts _ _ _, mapping) <- head <$> usesWithStale GetHieAst [nfp] - return $ head $ getNamesAtPoint asts pos mapping - refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do - ShakeExtras{hiedb} <- getShakeExtras fois <- HM.keys <$> getFilesOfInterestUntracked Just asts <- sequence <$> usesWithStale GetHieAst fois let foiRefs = concat $ mapMaybe (getNameAstLocations name) asts - refs <- nameDbRefs fois name hiedb + refs <- nameDbRefs fois name pure $ nubOrd $ foiRefs ++ refs -nameDbRefs :: [NormalizedFilePath] -> Name -> HieDb -> Action [Location] -nameDbRefs fois name hiedb = +nameDbRefs :: [NormalizedFilePath] -> Name -> Action [Location] +nameDbRefs fois name = do + ShakeExtras{hiedb} <- getShakeExtras case nameModule_maybe name of Nothing -> pure [] Just mod -> do From f7c2b7d1b9ff3892d315e93c667a5925dfa84b6c Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 1 Aug 2021 09:18:33 +0100 Subject: [PATCH 17/49] rename LHS of function decls --- .../src/Ide/Plugin/Rename.hs | 46 +++++++++++++------ 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 1550dc4851..a1fa3074d0 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -21,13 +21,12 @@ import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.AtPoint import HieDb.Query import Ide.Plugin.Retrie hiding (descriptor) +import Ide.PluginUtils import Ide.Types -import Language.Haskell.GHC.ExactPrint import Language.LSP.Server import Language.LSP.Types hiding (_changes) import Name -import Retrie hiding (getLoc) -import Ide.PluginUtils +import Retrie hiding (HsModule, getLoc) descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { @@ -36,25 +35,25 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { -- Todo: handle errors correctly (remove fromJust) renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newName) = response $ do - let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri +renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newNameStr) = response $ do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri -- TODO: nfp should be nfp of ref file + (HAR _ asts _ _ _, mapping) <- liftIO $ fromJust <$> runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) + session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) + let oldName = head $ getNamesAtPoint asts pos mapping + refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) -- rename LHS declarations - (annPs, _) <- liftIO $ fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (useWithStale GetAnnotatedParsedSource nfp) -- stale? + annPs <- liftIO $ fst . fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (useWithStale GetAnnotatedParsedSource nfp) -- stale? ccs <- lift getClientCapabilities let src = printA annPs - res = printA (fmap renameLhsDecls annPs) + res = printA (fmap (fmap (renameLhsDecls (mkRdrUnqual $ mkTcOcc $ T.unpack newNameStr) refs)) annPs) declEdits = makeDiffTextEdit (T.pack src) (T.pack res) -- use retrie to rename right-hand sides - (HAR _ asts _ _ _, mapping) <- liftIO $ fromJust <$> runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) - let oldName = head $ getNamesAtPoint asts pos mapping - session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) - refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) let emptyContextUpdater c i = const (return c) isType = isUpper $ head oldNameStr oldNameStr = getOccString oldName - rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newName) + rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newNameStr) (_errors, edits@WorkspaceEdit{_changes}) <- liftIO $ callRetrieWithTransformerAndUpdates (referenceTransformer refs) @@ -67,9 +66,26 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos return (edits {_changes = HM.update (Just . (<> declEdits)) uri <$> _changes}) --- TODO: rename LHS of top level decl in parsedSource (using grafts?) -renameLhsDecls :: ParsedSource -> ParsedSource -renameLhsDecls = error "not implemented" +-- TODO: rename lhs for signature declarations +-- TODO: rename lhs for type decls +-- TODO: export/import lists +renameLhsDecls :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs +renameLhsDecls newName refs ps@HsModule{hsmodDecls} = + ps {hsmodDecls = map (fmap replaceLhs) hsmodDecls} + where + replaceLhs :: HsDecl GhcPs -> HsDecl GhcPs + replaceLhs (ValD val funBind@FunBind{fun_id = L srcSpan _, fun_matches = fun_matches@MG{mg_alts}}) + | fromJust (srcSpanToLocation srcSpan) `elem` refs = + -- TODO: update srcSpan to newName length + ValD val (funBind { + fun_matches = fun_matches{ + mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts}}) + replaceLhs decl = decl + +renameLhsMatch :: RdrName -> Match GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs) +renameLhsMatch newName match@Match{m_ctxt = funrhs@FunRhs{mc_fun}} = + match{m_ctxt = funrhs{mc_fun = fmap (const newName) mc_fun}} +renameLhsMatch _ _ = error "Expected function match" referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match From 6fdb46561d8c84aee5996c2d99f05a74eb7023ff Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 5 Aug 2021 20:48:08 +0100 Subject: [PATCH 18/49] type/data decl renames, type sig renames --- .../src/Ide/Plugin/Rename.hs | 62 +++++++++++++------ 1 file changed, 43 insertions(+), 19 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index a1fa3074d0..f1729e1bd8 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -5,7 +5,6 @@ module Ide.Plugin.Rename (descriptor) where import Control.Monad.IO.Class -import Control.Monad.Trans.Class import qualified Data.Bifunctor import Data.Char import Data.Containers.ListUtils @@ -23,7 +22,6 @@ import HieDb.Query import Ide.Plugin.Retrie hiding (descriptor) import Ide.PluginUtils import Ide.Types -import Language.LSP.Server import Language.LSP.Types hiding (_changes) import Name import Retrie hiding (HsModule, getLoc) @@ -40,19 +38,19 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos (HAR _ asts _ _ _, mapping) <- liftIO $ fromJust <$> runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) let oldName = head $ getNamesAtPoint asts pos mapping + oldNameStr = getOccString oldName refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) -- rename LHS declarations - annPs <- liftIO $ fst . fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (useWithStale GetAnnotatedParsedSource nfp) -- stale? - ccs <- lift getClientCapabilities + annPs <- liftIO $ fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (use GetAnnotatedParsedSource nfp) let src = printA annPs - res = printA (fmap (fmap (renameLhsDecls (mkRdrUnqual $ mkTcOcc $ T.unpack newNameStr) refs)) annPs) + applyDeclRenames = renameLhsModDecls (mkRdrUnqual $ mkTcOcc $ T.unpack newNameStr) oldNameStr + res = printA $ (fmap . fmap) applyDeclRenames annPs declEdits = makeDiffTextEdit (T.pack src) (T.pack res) -- use retrie to rename right-hand sides let emptyContextUpdater c i = const (return c) isType = isUpper $ head oldNameStr - oldNameStr = getOccString oldName rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newNameStr) (_errors, edits@WorkspaceEdit{_changes}) <- liftIO $ callRetrieWithTransformerAndUpdates @@ -69,24 +67,50 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos -- TODO: rename lhs for signature declarations -- TODO: rename lhs for type decls -- TODO: export/import lists -renameLhsDecls :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs -renameLhsDecls newName refs ps@HsModule{hsmodDecls} = - ps {hsmodDecls = map (fmap replaceLhs) hsmodDecls} +-- TODO: update srcSpans to newName length +-- TODO: pattern syn type sig +-- TODO: restructure renameLhsModDecls +renameLhsModDecls :: RdrName -> String -> HsModule GhcPs -> HsModule GhcPs +renameLhsModDecls newName oldNameStr ps@HsModule{hsmodDecls} = + ps {hsmodDecls = map (fmap renameLhsDecl) hsmodDecls} where - replaceLhs :: HsDecl GhcPs -> HsDecl GhcPs - replaceLhs (ValD val funBind@FunBind{fun_id = L srcSpan _, fun_matches = fun_matches@MG{mg_alts}}) - | fromJust (srcSpanToLocation srcSpan) `elem` refs = - -- TODO: update srcSpan to newName length - ValD val (funBind { - fun_matches = fun_matches{ - mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts}}) - replaceLhs decl = decl + renameLhsDecl :: HsDecl GhcPs -> HsDecl GhcPs + renameLhsDecl (SigD xSig (TypeSig xTySig sigNames wc)) = + SigD xSig $ TypeSig + xTySig + (map (renameLhsSig newName oldNameStr <$>) sigNames) + wc + renameLhsDecl (ValD xVal funBind@FunBind{fun_id = L srcSpan funName, fun_matches = fun_matches@MG{mg_alts}}) + | getRdrString funName == oldNameStr = + ValD xVal $ funBind { + fun_id = L srcSpan newName + , fun_matches = fun_matches {mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts} + } + renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName = L srcSpan typeName}) + | getRdrString typeName == oldNameStr = + TyClD xTy $ dataDecl { + tcdLName = L srcSpan newName + } + renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName = L srcSpan typeName}) + | getRdrString typeName == oldNameStr = + TyClD xTy $ synDecl { + tcdLName = L srcSpan newName + } + renameLhsDecl decl = decl + +renameLhsSig :: RdrName -> String -> RdrName -> RdrName +renameLhsSig newName oldNameStr sigName + | getRdrString sigName == oldNameStr = newName +renameLhsSig _ _ sigName = sigName renameLhsMatch :: RdrName -> Match GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs) -renameLhsMatch newName match@Match{m_ctxt = funrhs@FunRhs{mc_fun}} = - match{m_ctxt = funrhs{mc_fun = fmap (const newName) mc_fun}} +renameLhsMatch newName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = + match{m_ctxt = funRhs{mc_fun = fmap (const newName) mc_fun}} renameLhsMatch _ _ = error "Expected function match" +getRdrString :: RdrName -> String +getRdrString = occNameString . rdrNameOcc + referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match | MatchResult _sub template <- match From 1f0094490c780dd664794fe7fadf4feea59ae793 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Fri, 6 Aug 2021 13:50:19 +0100 Subject: [PATCH 19/49] fix: only rename rhs when lhs successfully renames --- .../src/Ide/Plugin/Rename.hs | 41 ++++++++----------- 1 file changed, 18 insertions(+), 23 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index f1729e1bd8..41e030dd6d 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -49,26 +49,26 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos declEdits = makeDiffTextEdit (T.pack src) (T.pack res) -- use retrie to rename right-hand sides - let emptyContextUpdater c i = const (return c) + let emptyContextUpdater c i = const $ pure c isType = isUpper $ head oldNameStr rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newNameStr) - (_errors, edits@WorkspaceEdit{_changes}) <- liftIO $ - callRetrieWithTransformerAndUpdates - (referenceTransformer refs) - emptyContextUpdater - state - (hscEnv $ fst $ fromJust session) - [Right rewrite] - nfp - True + (_errors, edits@WorkspaceEdit{_changes}) <- + case declEdits of + List [] -> pure ([], WorkspaceEdit Nothing Nothing Nothing) + _ -> liftIO $ callRetrieWithTransformerAndUpdates + (referenceTransformer refs) + emptyContextUpdater + state + (hscEnv $ fst $ fromJust session) + [Right rewrite] + nfp + True - return (edits {_changes = HM.update (Just . (<> declEdits)) uri <$> _changes}) + pure $ edits {_changes = HM.insertWith (<>) uri declEdits <$> _changes} --- TODO: rename lhs for signature declarations --- TODO: rename lhs for type decls -- TODO: export/import lists -- TODO: update srcSpans to newName length --- TODO: pattern syn type sig +-- TODO: pattern syn type sig? -- TODO: restructure renameLhsModDecls renameLhsModDecls :: RdrName -> String -> HsModule GhcPs -> HsModule GhcPs renameLhsModDecls newName oldNameStr ps@HsModule{hsmodDecls} = @@ -83,13 +83,8 @@ renameLhsModDecls newName oldNameStr ps@HsModule{hsmodDecls} = renameLhsDecl (ValD xVal funBind@FunBind{fun_id = L srcSpan funName, fun_matches = fun_matches@MG{mg_alts}}) | getRdrString funName == oldNameStr = ValD xVal $ funBind { - fun_id = L srcSpan newName - , fun_matches = fun_matches {mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts} - } - renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName = L srcSpan typeName}) - | getRdrString typeName == oldNameStr = - TyClD xTy $ dataDecl { - tcdLName = L srcSpan newName + fun_id = L srcSpan newName, + fun_matches = fun_matches {mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts} } renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName = L srcSpan typeName}) | getRdrString typeName == oldNameStr = @@ -116,8 +111,8 @@ referenceTransformer refs _ctxt match | MatchResult _sub template <- match , Just loc <- srcSpanToLocation $ getOrigin $ astA $ tTemplate template -- Bug: incorrect loc -- , loc `elem` refs - = return match - | otherwise = return NoMatch + = pure match + | otherwise = pure NoMatch refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do From f0d9dfc018ef2c42425835f497a50ed5e31f834a Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 7 Aug 2021 03:25:38 +0100 Subject: [PATCH 20/49] rename export list, rename recursive data types --- .../src/Ide/Plugin/Rename.hs | 115 ++++++++++++------ 1 file changed, 80 insertions(+), 35 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 41e030dd6d..47fbbd2dc8 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -12,6 +12,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake @@ -26,14 +27,20 @@ import Language.LSP.Types hiding (_changes) import Name import Retrie hiding (HsModule, getLoc) +instance Show RdrName where + show = occNameString . rdrNameOcc + descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { pluginHandlers = mkPluginHandler STextDocumentRename renameProvider } --- Todo: handle errors correctly (remove fromJust) +-- TODO: update srcSpans to newName length +-- TODO: import lists + renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newNameStr) = response $ do +-- Todo: handle errors correctly (remove fromJust) let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri -- TODO: nfp should be nfp of ref file (HAR _ asts _ _ _, mapping) <- liftIO $ fromJust <$> runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) @@ -43,9 +50,11 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos -- rename LHS declarations annPs <- liftIO $ fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (use GetAnnotatedParsedSource nfp) - let src = printA annPs - applyDeclRenames = renameLhsModDecls (mkRdrUnqual $ mkTcOcc $ T.unpack newNameStr) oldNameStr - res = printA $ (fmap . fmap) applyDeclRenames annPs + let newRdrName = mkRdrUnqual $ mkTcOcc $ T.unpack newNameStr + src = printA annPs + res = printA $ (fmap . fmap) + (updateExports newRdrName oldNameStr . renameLhsModDecls newRdrName oldNameStr) + annPs declEdits = makeDiffTextEdit (T.pack src) (T.pack res) -- use retrie to rename right-hand sides @@ -66,46 +75,82 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos pure $ edits {_changes = HM.insertWith (<>) uri declEdits <$> _changes} --- TODO: export/import lists --- TODO: update srcSpans to newName length --- TODO: pattern syn type sig? --- TODO: restructure renameLhsModDecls +updateExports :: RdrName -> String -> HsModule GhcPs -> HsModule GhcPs +updateExports newName oldNameStr ps@HsModule{hsmodExports} = + ps {hsmodExports = (fmap . fmap) (map (fmap renameExport)) hsmodExports} + where + -- TODO: implement explicit type export renames + renameExport :: IE GhcPs -> IE GhcPs + renameExport (IEVar xVar ieName) + | show ieName == oldNameStr = + IEVar xVar (replaceLWrappedName ieName newName) + renameExport (IEThingAbs xThing ieName) + | show ieName == oldNameStr = + IEThingAbs xThing (replaceLWrappedName ieName newName) + renameExport (IEThingAll xThingAll ieName) + | show ieName == oldNameStr = + IEThingAll xThingAll (replaceLWrappedName ieName newName) + renameExport export = export + renameLhsModDecls :: RdrName -> String -> HsModule GhcPs -> HsModule GhcPs renameLhsModDecls newName oldNameStr ps@HsModule{hsmodDecls} = +-- TODO: pattern syn type sig? +-- TODO: restructure renameLhsModDecls ps {hsmodDecls = map (fmap renameLhsDecl) hsmodDecls} - where - renameLhsDecl :: HsDecl GhcPs -> HsDecl GhcPs - renameLhsDecl (SigD xSig (TypeSig xTySig sigNames wc)) = - SigD xSig $ TypeSig - xTySig - (map (renameLhsSig newName oldNameStr <$>) sigNames) - wc - renameLhsDecl (ValD xVal funBind@FunBind{fun_id = L srcSpan funName, fun_matches = fun_matches@MG{mg_alts}}) - | getRdrString funName == oldNameStr = - ValD xVal $ funBind { - fun_id = L srcSpan newName, - fun_matches = fun_matches {mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts} - } - renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName = L srcSpan typeName}) - | getRdrString typeName == oldNameStr = - TyClD xTy $ synDecl { - tcdLName = L srcSpan newName - } - renameLhsDecl decl = decl - -renameLhsSig :: RdrName -> String -> RdrName -> RdrName -renameLhsSig newName oldNameStr sigName - | getRdrString sigName == oldNameStr = newName -renameLhsSig _ _ sigName = sigName + where + renameLhsDecl :: HsDecl GhcPs -> HsDecl GhcPs + renameLhsDecl (SigD xSig (TypeSig xTySig sigNames wc)) = + SigD xSig $ TypeSig + xTySig + (map (fmap renameRdrname) sigNames) + wc + renameLhsDecl (ValD xVal funBind@FunBind{fun_id = L srcSpan funName, fun_matches = fun_matches@MG{mg_alts}}) + | show funName == oldNameStr = + ValD xVal $ funBind { + fun_id = L srcSpan newName, + fun_matches = fun_matches {mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts} + } + renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName = L srcSpan typeName, tcdDataDefn = hsDataDefn@HsDataDefn{dd_cons}}) + | show typeName == oldNameStr = + TyClD xTy $ dataDecl { + tcdLName = L srcSpan newName, + tcdDataDefn = hsDataDefn {dd_cons = map (fmap renameCon) dd_cons} + } + renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName = L srcSpan typeName}) + | show typeName == oldNameStr = + TyClD xTy $ synDecl { + tcdLName = L srcSpan newName + } + renameLhsDecl decl = decl + + renameRdrname :: RdrName -> RdrName + renameRdrname rdrName = if show rdrName == oldNameStr then newName else rdrName + + renameCon :: ConDecl GhcPs -> ConDecl GhcPs + renameCon conDecl = case conDecl of + cdGast@ConDeclGADT{con_args} -> cdGast {con_args = renameConArgs con_args} + cdH98@ConDeclH98{con_args} -> cdH98 {con_args = renameConArgs con_args} + xCd@(XConDecl _) -> xCd + + renameConArgs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs + renameConArgs (PrefixCon args) = PrefixCon $ map (fmap renameBang) args + renameConArgs (InfixCon a1 a2) = InfixCon (fmap renameBang a1) (fmap renameBang a2) + renameConArgs (RecCon record) = RecCon $ fmap (map (fmap renameField)) record + + renameBang :: BangType GhcPs -> BangType GhcPs + renameBang (HsTyVar a b name) = HsTyVar a b $ fmap renameRdrname name + renameBang _ = error "Expected type var" + + renameField :: ConDeclField GhcPs -> ConDeclField GhcPs + renameField conDeclField@ConDeclField{cd_fld_type} = + conDeclField {cd_fld_type = fmap renameBang cd_fld_type} + renameField _ = error "Expected constructor declaration field" renameLhsMatch :: RdrName -> Match GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs) renameLhsMatch newName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = match{m_ctxt = funRhs{mc_fun = fmap (const newName) mc_fun}} renameLhsMatch _ _ = error "Expected function match" -getRdrString :: RdrName -> String -getRdrString = occNameString . rdrNameOcc - referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match | MatchResult _sub template <- match From 77d3f106ed08d6c4ad4fc4da9c4d316b47fdd765 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 10 Aug 2021 16:00:51 +0100 Subject: [PATCH 21/49] rename import / hiding lists --- .../src/Ide/Plugin/Rename.hs | 213 +++++++++++------- .../src/Ide/Plugin/Retrie.hs | 2 +- 2 files changed, 133 insertions(+), 82 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 47fbbd2dc8..c8ecd67168 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -5,14 +5,15 @@ module Ide.Plugin.Rename (descriptor) where import Control.Monad.IO.Class +import Control.Monad.Trans.Except import qualified Data.Bifunctor import Data.Char import Data.Containers.ListUtils import qualified Data.HashMap.Strict as HM +import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T -import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake @@ -35,97 +36,113 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { pluginHandlers = mkPluginHandler STextDocumentRename renameProvider } --- TODO: update srcSpans to newName length --- TODO: import lists - renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newNameStr) = response $ do --- Todo: handle errors correctly (remove fromJust) - let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri -- TODO: nfp should be nfp of ref file - (HAR _ asts _ _ _, mapping) <- liftIO $ fromJust <$> runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) - session <- liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) +renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newRdrNameStr) = response $ do + nfp <- forceGetNfp uri + (HAR _ asts _ _ _, mapping) <- handleMaybeM "ast" $ liftIO $ runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) let oldName = head $ getNamesAtPoint asts pos mapping oldNameStr = getOccString oldName refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) - -- rename LHS declarations - annPs <- liftIO $ fromJust <$> runAction "Rename.GetAnnotatedParsedModule" state (use GetAnnotatedParsedSource nfp) - let newRdrName = mkRdrUnqual $ mkTcOcc $ T.unpack newNameStr - src = printA annPs - res = printA $ (fmap . fmap) - (updateExports newRdrName oldNameStr . renameLhsModDecls newRdrName oldNameStr) - annPs - declEdits = makeDiffTextEdit (T.pack src) (T.pack res) + -- rename LHS declarations / imports / exports + let refUris = nub [refFile | Location refFile _ <- refs] + newRdrName = mkRdrUnqual $ mkTcOcc $ T.unpack newRdrNameStr + refFiles <- mapM forceGetNfp refUris + sources <- mapM (handleMaybe "parsed source") =<< liftIO (runAction + "Rename.GetAnnotatedParsedModule" + state + (uses GetAnnotatedParsedSource refFiles)) + let declEdits = filter + (not . isListEmpty . snd) + (zip refUris $ map (lhsDeclEdits newRdrName refs) sources) -- use retrie to rename right-hand sides + (session, _) <- handleMaybeM "session deps" . liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) let emptyContextUpdater c i = const $ pure c isType = isUpper $ head oldNameStr - rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newNameStr) - (_errors, edits@WorkspaceEdit{_changes}) <- - case declEdits of - List [] -> pure ([], WorkspaceEdit Nothing Nothing Nothing) - _ -> liftIO $ callRetrieWithTransformerAndUpdates - (referenceTransformer refs) - emptyContextUpdater - state - (hscEnv $ fst $ fromJust session) - [Right rewrite] - nfp - True - - pure $ edits {_changes = HM.insertWith (<>) uri declEdits <$> _changes} - -updateExports :: RdrName -> String -> HsModule GhcPs -> HsModule GhcPs -updateExports newName oldNameStr ps@HsModule{hsmodExports} = - ps {hsmodExports = (fmap . fmap) (map (fmap renameExport)) hsmodExports} + rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newRdrNameStr) + (_errors, retrieEdit@WorkspaceEdit{_changes}) <- liftIO $ callRetrieWithTransformerAndUpdates + (referenceTransformer refs) + emptyContextUpdater + state + (hscEnv session) + [Right rewrite] + nfp + False + + pure $ case declEdits of + [] -> WorkspaceEdit Nothing Nothing Nothing + declEdits' -> retrieEdit { + _changes = foldl1 (.) (map (uncurry $ HM.insertWith (<>)) declEdits') <$> _changes + } + +------------------------------------------------------------------------------- +-- Source renaming + +lhsDeclEdits :: RdrName -> [Location] -> Annotated ParsedSource -> List TextEdit +lhsDeclEdits newRdrName refs annPs = makeDiffTextEdit src res + where + src = T.pack $ printA annPs + updateMod = + updateImports newRdrName refs . + updateExports newRdrName refs . + updateLhsDecls newRdrName refs + res = T.pack $ printA $ (fmap . fmap) updateMod annPs + +updateImports :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs +updateImports newRdrName refs ps@HsModule{hsmodImports} = + ps {hsmodImports = map (fmap renameImport) hsmodImports} where - -- TODO: implement explicit type export renames - renameExport :: IE GhcPs -> IE GhcPs - renameExport (IEVar xVar ieName) - | show ieName == oldNameStr = - IEVar xVar (replaceLWrappedName ieName newName) - renameExport (IEThingAbs xThing ieName) - | show ieName == oldNameStr = - IEThingAbs xThing (replaceLWrappedName ieName newName) - renameExport (IEThingAll xThingAll ieName) - | show ieName == oldNameStr = - IEThingAll xThingAll (replaceLWrappedName ieName newName) - renameExport export = export - -renameLhsModDecls :: RdrName -> String -> HsModule GhcPs -> HsModule GhcPs -renameLhsModDecls newName oldNameStr ps@HsModule{hsmodDecls} = --- TODO: pattern syn type sig? --- TODO: restructure renameLhsModDecls + renameImport :: ImportDecl GhcPs -> ImportDecl GhcPs + renameImport importDecl@ImportDecl{ideclHiding = Just (isHiding, names)} = + importDecl { + ideclHiding = + Just (isHiding, fmap (map (fmap $ renameIE refs newRdrName)) names) + } + renameImport importDecl = importDecl + +updateExports :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs +updateExports newRdrName refs ps@HsModule{hsmodExports} = + ps {hsmodExports = (fmap . fmap) (map (fmap $ renameIE refs newRdrName)) hsmodExports} + +-- TODO: implement explicit type import/export renames +renameIE :: [Location] -> RdrName -> IE GhcPs -> IE GhcPs +renameIE refs newRdrName (IEVar xVar ieName) + | isRef refs ieName = + IEVar xVar (replaceLWrappedName ieName newRdrName) +renameIE refs newRdrName (IEThingAbs xThing ieName) + | isRef refs ieName = + IEThingAbs xThing (replaceLWrappedName ieName newRdrName) +renameIE refs newRdrName (IEThingAll xThingAll ieName) + | isRef refs ieName = + IEThingAll xThingAll (replaceLWrappedName ieName newRdrName) +renameIE refs newRdrName IEThingWith{} + = error "not implemented explicit type import/export renames yet" +renameIE _ _ export = export + +updateLhsDecls :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs +updateLhsDecls newRdrName refs ps@HsModule{hsmodDecls} = ps {hsmodDecls = map (fmap renameLhsDecl) hsmodDecls} where renameLhsDecl :: HsDecl GhcPs -> HsDecl GhcPs renameLhsDecl (SigD xSig (TypeSig xTySig sigNames wc)) = - SigD xSig $ TypeSig - xTySig - (map (fmap renameRdrname) sigNames) - wc - renameLhsDecl (ValD xVal funBind@FunBind{fun_id = L srcSpan funName, fun_matches = fun_matches@MG{mg_alts}}) - | show funName == oldNameStr = - ValD xVal $ funBind { - fun_id = L srcSpan newName, - fun_matches = fun_matches {mg_alts = fmap ((: []) . (fmap (renameLhsMatch newName) . head)) mg_alts} + SigD xSig $ TypeSig xTySig (map renameRdrName sigNames) wc + renameLhsDecl (ValD xVal funBind@FunBind{fun_id, fun_matches = fun_matches@MG{mg_alts}}) + | isRef refs fun_id = ValD xVal $ funBind { + fun_id = fmap (const newRdrName) fun_id, + fun_matches = fun_matches {mg_alts = fmap ((: []) . fmap (renameLhsMatch newRdrName) . head) mg_alts} + } + renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName, tcdDataDefn = hsDataDefn@HsDataDefn{dd_cons}}) + | isRef refs tcdLName = TyClD xTy $ dataDecl { + tcdLName = fmap (const newRdrName) tcdLName, + tcdDataDefn = hsDataDefn {dd_cons = map (fmap renameCon) dd_cons} } - renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName = L srcSpan typeName, tcdDataDefn = hsDataDefn@HsDataDefn{dd_cons}}) - | show typeName == oldNameStr = - TyClD xTy $ dataDecl { - tcdLName = L srcSpan newName, - tcdDataDefn = hsDataDefn {dd_cons = map (fmap renameCon) dd_cons} - } - renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName = L srcSpan typeName}) - | show typeName == oldNameStr = - TyClD xTy $ synDecl { - tcdLName = L srcSpan newName + renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName}) + | isRef refs tcdLName = TyClD xTy $ synDecl { + tcdLName = fmap (const newRdrName) tcdLName } renameLhsDecl decl = decl - renameRdrname :: RdrName -> RdrName - renameRdrname rdrName = if show rdrName == oldNameStr then newName else rdrName - renameCon :: ConDecl GhcPs -> ConDecl GhcPs renameCon conDecl = case conDecl of cdGast@ConDeclGADT{con_args} -> cdGast {con_args = renameConArgs con_args} @@ -138,27 +155,39 @@ renameLhsModDecls newName oldNameStr ps@HsModule{hsmodDecls} = renameConArgs (RecCon record) = RecCon $ fmap (map (fmap renameField)) record renameBang :: BangType GhcPs -> BangType GhcPs - renameBang (HsTyVar a b name) = HsTyVar a b $ fmap renameRdrname name - renameBang _ = error "Expected type var" + renameBang (HsTyVar xTyVar p name) = HsTyVar xTyVar p $ renameRdrName name + renameBang _ = error "Expected type var" renameField :: ConDeclField GhcPs -> ConDeclField GhcPs renameField conDeclField@ConDeclField{cd_fld_type} = conDeclField {cd_fld_type = fmap renameBang cd_fld_type} renameField _ = error "Expected constructor declaration field" + renameRdrName :: Located RdrName -> Located RdrName + renameRdrName rdrName + | isRef refs rdrName = fmap (const newRdrName) rdrName + | otherwise = rdrName + renameLhsMatch :: RdrName -> Match GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs) -renameLhsMatch newName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = - match{m_ctxt = funRhs{mc_fun = fmap (const newName) mc_fun}} +renameLhsMatch newRdrName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = + match{m_ctxt = funRhs{mc_fun = fmap (const newRdrName) mc_fun}} renameLhsMatch _ _ = error "Expected function match" +------------------------------------------------------------------------------- +-- retrie + +-- limits matches to reference locations referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match | MatchResult _sub template <- match - , Just loc <- srcSpanToLocation $ getOrigin $ astA $ tTemplate template -- Bug: incorrect loc - -- , loc `elem` refs + , srcSpan <- getOrigin $ astA $ tTemplate template -- Bug: incorrect loc +-- , isRef refs srcSpan = pure match | otherwise = pure NoMatch +------------------------------------------------------------------------------- +-- reference finding + refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do fois <- HM.keys <$> getFilesOfInterestUntracked @@ -174,9 +203,31 @@ nameDbRefs fois name = do Nothing -> pure [] Just mod -> do let exclude = map fromNormalizedFilePath fois - rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + rows <- liftIO $ findReferences + hiedb + True + (nameOccName name) + (Just $ moduleName mod) + (Just $ moduleUnitId mod) + exclude pure $ mapMaybe rowToLoc rows getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] getNameAstLocations name (HAR _ _ rm _ _, mapping) = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm + +------------------------------------------------------------------------------- +-- util + +forceGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath +forceGetNfp nfp = handleMaybe "uri" $ toNormalizedFilePath <$> uriToFilePath nfp + +isTopLevelSpan :: SrcSpan -> Bool +isTopLevelSpan (RealSrcSpan srcSpan) = srcSpanStartCol srcSpan == 1 +isTopLevelSpan _ = False + +isListEmpty :: List a -> Bool +isListEmpty (List xs) = null xs + +isRef :: Retrie.HasSrcSpan a => [Location] -> a -> Bool +isRef refs = (`elem` refs) . fromJust . srcSpanToLocation . getLoc diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 1036ffb7fc..49666fd78b 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -15,7 +15,7 @@ {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE RankNTypes #-} -module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, RunRetrieParams(..), response) where +module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, RunRetrieParams(..), response, handleMaybe, handleMaybeM) where import Control.Concurrent.Extra (readVar) import Control.Exception.Safe (Exception (..), From 82405e5a43386d8bd5d887df0c38b7d955c954e9 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 10 Aug 2021 19:26:30 +0100 Subject: [PATCH 22/49] fix: rename all LHSs of functions with multiple definition --- .../src/Ide/Plugin/Rename.hs | 34 +++++++++++-------- plugins/hls-rename-plugin/test/Main.hs | 9 ++--- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index c8ecd67168..97f9b49a38 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -54,21 +54,22 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos (uses GetAnnotatedParsedSource refFiles)) let declEdits = filter (not . isListEmpty . snd) - (zip refUris $ map (lhsDeclEdits newRdrName refs) sources) + (zip refUris $ map (sourceEdits newRdrName refs) sources) -- use retrie to rename right-hand sides (session, _) <- handleMaybeM "session deps" . liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) let emptyContextUpdater c i = const $ pure c isType = isUpper $ head oldNameStr rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newRdrNameStr) - (_errors, retrieEdit@WorkspaceEdit{_changes}) <- liftIO $ callRetrieWithTransformerAndUpdates - (referenceTransformer refs) - emptyContextUpdater - state - (hscEnv session) - [Right rewrite] - nfp - False + (_errors, retrieEdit@WorkspaceEdit{_changes}) <- + liftIO $ callRetrieWithTransformerAndUpdates + (\_ match -> pure match) -- Temp empty + emptyContextUpdater + state + (hscEnv session) + [Right rewrite] + nfp + False pure $ case declEdits of [] -> WorkspaceEdit Nothing Nothing Nothing @@ -79,8 +80,8 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos ------------------------------------------------------------------------------- -- Source renaming -lhsDeclEdits :: RdrName -> [Location] -> Annotated ParsedSource -> List TextEdit -lhsDeclEdits newRdrName refs annPs = makeDiffTextEdit src res +sourceEdits :: RdrName -> [Location] -> Annotated ParsedSource -> List TextEdit +sourceEdits newRdrName refs annPs = makeDiffTextEdit src res where src = T.pack $ printA annPs updateMod = @@ -130,7 +131,7 @@ updateLhsDecls newRdrName refs ps@HsModule{hsmodDecls} = renameLhsDecl (ValD xVal funBind@FunBind{fun_id, fun_matches = fun_matches@MG{mg_alts}}) | isRef refs fun_id = ValD xVal $ funBind { fun_id = fmap (const newRdrName) fun_id, - fun_matches = fun_matches {mg_alts = fmap ((: []) . fmap (renameLhsMatch newRdrName) . head) mg_alts} + fun_matches = fun_matches {mg_alts = fmap (map (fmap $ renameLhsMatch newRdrName)) mg_alts} } renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName, tcdDataDefn = hsDataDefn@HsDataDefn{dd_cons}}) | isRef refs tcdLName = TyClD xTy $ dataDecl { @@ -181,7 +182,7 @@ referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs _ctxt match | MatchResult _sub template <- match , srcSpan <- getOrigin $ astA $ tTemplate template -- Bug: incorrect loc --- , isRef refs srcSpan + , isRef' refs srcSpan = pure match | otherwise = pure NoMatch @@ -191,7 +192,7 @@ referenceTransformer refs _ctxt match refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do fois <- HM.keys <$> getFilesOfInterestUntracked - Just asts <- sequence <$> usesWithStale GetHieAst fois + asts <- fromJust . sequence <$> usesWithStale GetHieAst fois let foiRefs = concat $ mapMaybe (getNameAstLocations name) asts refs <- nameDbRefs fois name pure $ nubOrd $ foiRefs ++ refs @@ -230,4 +231,7 @@ isListEmpty :: List a -> Bool isListEmpty (List xs) = null xs isRef :: Retrie.HasSrcSpan a => [Location] -> a -> Bool -isRef refs = (`elem` refs) . fromJust . srcSpanToLocation . getLoc +isRef refs = isRef' refs . getLoc + +isRef' :: [Location] -> SrcSpan -> Bool +isRef' refs = (`elem` refs) . fromJust . srcSpanToLocation diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index f4a291170a..87fd645269 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -13,8 +13,7 @@ renamePlugin = Rename.descriptor "rename" tests :: TestTree tests = testGroup "rename" - [ expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "function name" "FunctionName" $ \doc -> do + [ goldenWithRename "function name" "FunctionName" $ \doc -> do rename doc (Position 3 1) "baz" -- foo :: Int -> Int , expectFailBecause "Declaration renames not implemented" $ goldenWithRename "function argument" "FunctionArgument" $ \doc -> do @@ -37,11 +36,9 @@ tests = testGroup "rename" , expectFailBecause "Declaration renames not implemented" $ goldenWithRename "type variable" "TypeVariable" $ \doc -> do rename doc (Position 0 13) "b" -- bar :: Maybe a -> Maybe a - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "imported function" "ImportedFunction" $ \doc -> do + , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do rename doc (Position 0 35) "baz" -- import FunctionArgument (foo) - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "GADT" "Gadt" $ \doc -> do + , goldenWithRename "GADT" "Gadt" $ \doc -> do rename doc (Position 6 35) "Expr" -- Even :: Expression Int -> Expression Bool ] From 295422563522510fbf1a41a1950f606395ed0b08 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 10 Aug 2021 19:26:34 +0100 Subject: [PATCH 23/49] fix: rename self-recursive functions --- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 49666fd78b..2ec5ffdb43 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -436,7 +436,7 @@ callRetrieWithTransformerAndUpdates transformer contextUpdater state session rew unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0 (originFixities, originParsedModule) <- reuseParsedModule origin - retrie <- do (\specs -> applyWithUpdate updateContext (map (setRewriteTransformer transformer) specs) + retrie <- do (\specs -> applyWithUpdate contextUpdater (map (setRewriteTransformer transformer) specs) >> addImports annotatedImports) <$> parseRewriteSpecs (\_f -> return $ NoCPP originParsedModule) From 9e90f5357d325de8689d5f2db094c593fbc54f73 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Fri, 13 Aug 2021 00:04:33 +0100 Subject: [PATCH 24/49] Limit retrie rewrite locations to references locations, organise/add tests cases --- .../src/Ide/Plugin/Rename.hs | 87 +++++++++++++++---- plugins/hls-rename-plugin/test/Main.hs | 73 ++++++++++------ .../testdata/ExportedFunction.expected.hs | 5 ++ .../test/testdata/ExportedFunction.hs | 5 ++ .../hls-rename-plugin/test/testdata/Foo.hs | 4 + .../test/testdata/HiddenFunction.expected.hs | 4 + .../test/testdata/HiddenFunction.hs | 4 + .../testdata/ImportedFunction.expected.hs | 2 +- .../test/testdata/ImportedFunction.hs | 2 +- .../test/testdata/Indentation.expected.hs | 4 + .../test/testdata/Indentation.hs | 4 + .../testdata/QualifiedFunction.expected.hs | 4 +- .../test/testdata/QualifiedFunction.hs | 4 +- .../test/testdata/ShadowedName.expected.hs | 6 +- .../test/testdata/ShadowedName.hs | 4 +- .../hls-rename-plugin/test/testdata/hie.yaml | 4 + 16 files changed, 162 insertions(+), 54 deletions(-) create mode 100644 plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/Foo.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/Indentation.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/Indentation.hs diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 97f9b49a38..2c4e3ee4da 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,22 +15,21 @@ import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.AtPoint +import GhcPlugins hiding (getLoc, (<>)) import HieDb.Query import Ide.Plugin.Retrie hiding (descriptor) import Ide.PluginUtils import Ide.Types import Language.LSP.Types hiding (_changes) -import Name import Retrie hiding (HsModule, getLoc) - -instance Show RdrName where - show = occNameString . rdrNameOcc +import Retrie.SYB descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { @@ -58,13 +58,12 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos -- use retrie to rename right-hand sides (session, _) <- handleMaybeM "session deps" . liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) - let emptyContextUpdater c i = const $ pure c - isType = isUpper $ head oldNameStr + let isType = isUpper $ head oldNameStr rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newRdrNameStr) (_errors, retrieEdit@WorkspaceEdit{_changes}) <- liftIO $ callRetrieWithTransformerAndUpdates - (\_ match -> pure match) -- Temp empty - emptyContextUpdater + (referenceTransformer refs) + contextUpdater state (hscEnv session) [Right rewrite] @@ -77,6 +76,7 @@ renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _changes = foldl1 (.) (map (uncurry $ HM.insertWith (<>)) declEdits') <$> _changes } + ------------------------------------------------------------------------------- -- Source renaming @@ -174,17 +174,67 @@ renameLhsMatch newRdrName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = match{m_ctxt = funRhs{mc_fun = fmap (const newRdrName) mc_fun}} renameLhsMatch _ _ = error "Expected function match" + ------------------------------------------------------------------------------- -- retrie -- limits matches to reference locations referenceTransformer :: [Location] -> MatchResultTransformer -referenceTransformer refs _ctxt match - | MatchResult _sub template <- match - , srcSpan <- getOrigin $ astA $ tTemplate template -- Bug: incorrect loc - , isRef' refs srcSpan - = pure match - | otherwise = pure NoMatch +referenceTransformer refs Context{ctxtBinders} match + | MatchResult _sub template <- match + , trace ("\nRefs: " ++ show refs ++ "\nContext: " ++ show (map getRdrLoc ctxtBinders)) + any (containsRef . getRdrLoc) ctxtBinders = pure match + | otherwise = pure NoMatch + where + containsRef srcSpan = any (flip isSubspanOf srcSpan . locToSpan) refs + getRdrLoc (Exact name) = nameSrcSpan name + getRdrLoc _ = error "Expected exact name" + + +-- Hacky use of ctxtBinders to track match spans +contextUpdater :: (Typeable b, Monad f) => Context -> Int -> b -> f Context +contextUpdater c@Context{ctxtBinders} i = const (pure c) + `extQ` (return . updType) + `extQ` (return . updExpr) + `extQ` (return . updMatch) + `extQ` (return . updTyDecl) + where + makeName = Exact . mkInternalName initTyVarUnique (mkVarOcc "") + + updType :: LHsType GhcPs -> Context + updType (L _ (HsAppTy _ (L matchSpan _) _)) = + c {ctxtBinders = makeName matchSpan : ctxtBinders} + updType (L matchSpan ty) = + c {ctxtBinders = makeName matchSpan : ctxtBinders} + + updExpr :: LHsExpr GhcPs -> Context + updExpr (L _ (HsApp _ (L matchSpan a) _)) = + c {ctxtBinders = makeName matchSpan : ctxtBinders} + updExpr (L matchSpan _) = + c {ctxtBinders = makeName matchSpan : ctxtBinders} + + -- updTyDecl :: LTyClDecl GhcPs -> Context + -- updTyDecl (L matchSpan SynDecl{tcdLName}) = + -- c {ctxtBinders = makeName (matchSpan `subtractSrcSpans` getLoc tcdLName) : ctxtBinders} + -- updTyDecl (L _ _) = c + + updTyDecl :: TyClDecl GhcPs -> Context + updTyDecl SynDecl{tcdRhs} = + c {ctxtBinders = makeName (getLoc tcdRhs) : ctxtBinders} + updTyDecl _ = c + + updMatch :: LMatch GhcPs (LHsExpr GhcPs) -> Context + updMatch (L matchSpan Match{m_ctxt = FunRhs{mc_fun = L funNameSpan _}}) = + c {ctxtBinders = makeName (matchSpan `subtractSrcSpans` funNameSpan) : ctxtBinders} + updMatch (L matchSpan _) = c {ctxtBinders = makeName matchSpan : ctxtBinders} + +subtractSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +subtractSrcSpans span1 (RealSrcSpan span2) + = mkSrcSpan startLoc endLoc + where + startLoc = mkSrcLoc (srcSpanFile span2) (srcSpanStartLine span2) (srcSpanEndCol span2) + endLoc = srcSpanEnd span1 +subtractSrcSpans _ _ = error "" ------------------------------------------------------------------------------- -- reference finding @@ -192,7 +242,7 @@ referenceTransformer refs _ctxt match refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do fois <- HM.keys <$> getFilesOfInterestUntracked - asts <- fromJust . sequence <$> usesWithStale GetHieAst fois + Just asts <- sequence <$> usesWithStale GetHieAst fois let foiRefs = concat $ mapMaybe (getNameAstLocations name) asts refs <- nameDbRefs fois name pure $ nubOrd $ foiRefs ++ refs @@ -217,6 +267,7 @@ getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Locatio getNameAstLocations name (HAR _ _ rm _ _, mapping) = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm + ------------------------------------------------------------------------------- -- util @@ -235,3 +286,9 @@ isRef refs = isRef' refs . getLoc isRef' :: [Location] -> SrcSpan -> Bool isRef' refs = (`elem` refs) . fromJust . srcSpanToLocation + +locToSpan :: Location -> SrcSpan +locToSpan (Location uri (Range (Position l c) (Position l' c'))) = + mkSrcSpan (mkSrcLoc' uri (succ l) (succ c)) (mkSrcLoc' uri (succ l') (succ c')) + where + mkSrcLoc' = mkSrcLoc . mkFastString . fromJust . uriToFilePath diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 87fd645269..72d319849a 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -13,37 +13,54 @@ renamePlugin = Rename.descriptor "rename" tests :: TestTree tests = testGroup "rename" - [ goldenWithRename "function name" "FunctionName" $ \doc -> do - rename doc (Position 3 1) "baz" -- foo :: Int -> Int - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "function argument" "FunctionArgument" $ \doc -> do - rename doc (Position 3 4) "y" -- foo x = x + 1 - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do - rename doc (Position 3 24) "baz" -- bar = FunctionArgument.foo - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "record field" "RecordField" $ \doc -> do - rename doc (Position 6 9) "number" -- foo Bam {n = y} = Bam {n = y + 5, s = ""} - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do - rename doc (Position 3 8) "y" -- x = 20 - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do - rename doc (Position 2 15) "BinaryTree" -- rotateRight :: Tree a -> Tree a - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "data constructor" "DataConstructor" $ \doc -> do - rename doc (Position 0 13) "Apply" -- data Expr = Op Int Int - , expectFailBecause "Declaration renames not implemented" $ - goldenWithRename "type variable" "TypeVariable" $ \doc -> do - rename doc (Position 0 13) "b" -- bar :: Maybe a -> Maybe a - , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do - rename doc (Position 0 35) "baz" -- import FunctionArgument (foo) - , goldenWithRename "GADT" "Gadt" $ \doc -> do - rename doc (Position 6 35) "Expr" -- Even :: Expression Int -> Expression Bool + [ testGroup "Top-level renames" + [ ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "function name" "FunctionName" $ \doc -> do + rename doc (Position 3 1) "baz" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "GADT" "Gadt" $ \doc -> do + rename doc (Position 6 37) "Expr" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "imported function" "ImportedFunction" $ \doc -> do + rename doc (Position 3 8) "baz" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "exported function" "ExportedFunction" $ \doc -> do + rename doc (Position 2 1) "quux" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "hidden function" "HiddenFunction" $ \doc -> do + rename doc (Position 0 32) "quux" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "allign indentation" "Indentation" $ \doc -> do + rename doc (Position 0 2) "fooBarQuux" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do + rename doc (Position 1 1) "baz" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do + rename doc (Position 2 15) "BinaryTree" + , expectFailBecause "Not implemented yet" $ + goldenWithRename "data constructor" "DataConstructor" $ \doc -> do + rename doc (Position 0 13) "Apply" + , expectFailBecause "qualified rename not implemented yet" $ + goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do + rename doc (Position 3 12) "baz" + ] + , testGroup "non Top-level renames" + [ expectFailBecause "Only top-level renames are implemented" $ + goldenWithRename "function argument" "FunctionArgument" $ \doc -> do + rename doc (Position 3 4) "y" + , expectFailBecause "Only top-level renames are implemented" $ + goldenWithRename "record field" "RecordField" $ \doc -> do + rename doc (Position 6 9) "number" + , expectFailBecause "Only top-level renames are implemented" $ + goldenWithRename "type variable" "TypeVariable" $ \doc -> do + rename doc (Position 0 13) "b" + ] ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithRename title path = goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" +goldenWithRename title path = + goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs new file mode 100644 index 0000000000..568edb36db --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.expected.hs @@ -0,0 +1,5 @@ +module ExportedFunction (quux) where + +quux :: Num p => [a] -> p +quux [] = 0 +quux xs = 1 diff --git a/plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs new file mode 100644 index 0000000000..3adb72dc9f --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ExportedFunction.hs @@ -0,0 +1,5 @@ +module ExportedFunction (foo) where + +foo :: Num p => [a] -> p +foo [] = 0 +foo xs = 1 diff --git a/plugins/hls-rename-plugin/test/testdata/Foo.hs b/plugins/hls-rename-plugin/test/testdata/Foo.hs new file mode 100644 index 0000000000..c4850149b4 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +foo :: Int -> Int +foo x = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs new file mode 100644 index 0000000000..3195291c66 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.expected.hs @@ -0,0 +1,4 @@ +import Foo hiding (quux) + +foo :: Int -> Int +foo x = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs new file mode 100644 index 0000000000..eacb9d1a4c --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/HiddenFunction.hs @@ -0,0 +1,4 @@ +import Foo hiding (foo) + +foo :: Int -> Int +foo x = 0 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs index b8b450c0ae..8f0cbcf888 100644 --- a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs +++ b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.expected.hs @@ -1,4 +1,4 @@ -import FunctionArgument (baz) +import Foo (baz) bar :: Int -> Int bar = baz diff --git a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs index 79eb5c4aab..56361fc64b 100644 --- a/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs +++ b/plugins/hls-rename-plugin/test/testdata/ImportedFunction.hs @@ -1,4 +1,4 @@ -import FunctionArgument (foo) +import Foo (foo) bar :: Int -> Int bar = foo diff --git a/plugins/hls-rename-plugin/test/testdata/Indentation.expected.hs b/plugins/hls-rename-plugin/test/testdata/Indentation.expected.hs new file mode 100644 index 0000000000..9033a89d87 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Indentation.expected.hs @@ -0,0 +1,4 @@ +fooBarQuux :: Maybe Integer +fooBarQuux = do x <- Just 5 + t <- Just 10 + pure $ x + t diff --git a/plugins/hls-rename-plugin/test/testdata/Indentation.hs b/plugins/hls-rename-plugin/test/testdata/Indentation.hs new file mode 100644 index 0000000000..aa121ac984 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Indentation.hs @@ -0,0 +1,4 @@ +foo :: Maybe Integer +foo = do x <- Just 5 + t <- Just 10 + pure $ x + t diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs index 6b98d6f2a9..808c12b066 100644 --- a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.expected.hs @@ -1,4 +1,4 @@ -import qualified FunctionArgument +import qualified Foo bar :: Int -> Int -bar = FunctionArgument.baz +bar = Foo.baz diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs index 9bb1832ff0..01581c0c8d 100644 --- a/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedFunction.hs @@ -1,4 +1,4 @@ -import qualified FunctionArgument +import qualified Foo bar :: Int -> Int -bar = FunctionArgument.foo +bar = Foo.foo diff --git a/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs b/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs index ac2da171bf..7c6391176a 100644 --- a/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs +++ b/plugins/hls-rename-plugin/test/testdata/ShadowedName.expected.hs @@ -1,4 +1,4 @@ -foo :: Int -> Int -foo x = y + 10 +baz :: Int -> Int +baz x = foo + 10 where - y = 20 + foo = 20 diff --git a/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs b/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs index f7fbfc641f..513f8fa89f 100644 --- a/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs +++ b/plugins/hls-rename-plugin/test/testdata/ShadowedName.hs @@ -1,4 +1,4 @@ foo :: Int -> Int -foo x = x + 10 +foo x = foo + 10 where - x = 20 + foo = 20 diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml index d18faf0a8e..d52005a4cb 100644 --- a/plugins/hls-rename-plugin/test/testdata/hie.yaml +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -4,6 +4,8 @@ cradle: - "FunctionName" - "FunctionArgument" - "ImportedFunction" + - "ExportedFunction" + - "HiddenFunction" - "QualifiedFunction" - "RecordField" - "ShadowedName" @@ -11,3 +13,5 @@ cradle: - "TypeConstructor" - "DataConstructor" - "Gadt" + - "Indentation" + - "Foo" From b54a952243bd95601859b48e43de0a9e5811c499 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Fri, 13 Aug 2021 00:25:06 +0100 Subject: [PATCH 25/49] disable plugin in stack for < ghc 8.8 --- stack-8.6.4.yaml | 1 - stack-8.6.5.yaml | 1 - 2 files changed, 2 deletions(-) diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index cc994411c3..565621d7ee 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -15,7 +15,6 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - ./plugins/hls-tactics-plugin diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index e00c50e9e5..bbe6c651f3 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -14,7 +14,6 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - ./plugins/hls-tactics-plugin From 75f411004274629b7f6c41b8bdf226d67effe50a Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 14 Aug 2021 07:04:36 +0100 Subject: [PATCH 26/49] code style --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 8 +- .../hls-rename-plugin/hls-rename-plugin.cabal | 2 +- .../src/Ide/Plugin/Rename.hs | 194 +++++++++--------- .../src/Ide/Plugin/Retrie.hs | 22 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- 6 files changed, 118 insertions(+), 112 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 52226967e2..181bfce32e 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -16,7 +16,7 @@ module Development.IDE.Spans.AtPoint ( , computeTypeReferences , FOIReferences(..) , defRowToSymbolInfo - , getNamesAtPoint + , getAstNamesAtPoint , toCurrentLocation , rowToLoc ) where @@ -93,7 +93,7 @@ foiReferencesAtPoint file pos (FOIReferences asts) = case HM.lookup file asts of Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> - let names = getNamesAtPoint hf pos mapping + let names = getAstNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where @@ -103,8 +103,8 @@ foiReferencesAtPoint file pos (FOIReferences asts) = $ concat $ mapMaybe (`M.lookup` tr) names in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) -getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] -getNamesAtPoint hf pos mapping = +getAstNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] +getAstNamesAtPoint hf pos mapping = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) where posFile = fromMaybe pos $ fromCurrentPosition mapping pos diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index bb0609a377..4ea743136d 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -25,7 +25,7 @@ library , lsp-types , lsp , hls-plugin-api ^>=1.1 - , ghcide >=1.4.0.4 + , ghcide >=1.4.0.4 && <1.5 , retrie >0.1.1.1 , transformers , hls-retrie-plugin >= 1.0.1.1 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 2c4e3ee4da..c7bef6b846 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Rename (descriptor) where import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.Except import qualified Data.Bifunctor import Data.Char @@ -15,7 +15,6 @@ import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T -import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake @@ -24,12 +23,15 @@ import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.AtPoint import GhcPlugins hiding (getLoc, (<>)) import HieDb.Query +import Ide.Plugin.Config import Ide.Plugin.Retrie hiding (descriptor) import Ide.PluginUtils import Ide.Types -import Language.LSP.Types hiding (_changes) +import Language.LSP.Server +import Language.LSP.Types hiding (_changes, _range) import Retrie hiding (HsModule, getLoc) import Retrie.SYB +import Control.Monad descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { @@ -37,61 +39,58 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { } renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state pluginId (RenameParams tdi@(TextDocumentIdentifier uri) pos _progToken newRdrNameStr) = response $ do +renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) = response $ do + -- get reference locations nfp <- forceGetNfp uri - (HAR _ asts _ _ _, mapping) <- handleMaybeM "ast" $ liftIO $ runAction "Rename.GetHieAst" state (useWithStale GetHieAst nfp) - let oldName = head $ getNamesAtPoint asts pos mapping - oldNameStr = getOccString oldName + oldName <- head <$> getNamesAtPos state pos nfp refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) - - -- rename LHS declarations / imports / exports - let refUris = nub [refFile | Location refFile _ <- refs] - newRdrName = mkRdrUnqual $ mkTcOcc $ T.unpack newRdrNameStr - refFiles <- mapM forceGetNfp refUris - sources <- mapM (handleMaybe "parsed source") =<< liftIO (runAction - "Rename.GetAnnotatedParsedModule" - state - (uses GetAnnotatedParsedSource refFiles)) - let declEdits = filter - (not . isListEmpty . snd) - (zip refUris $ map (sourceEdits newRdrName refs) sources) - - -- use retrie to rename right-hand sides - (session, _) <- handleMaybeM "session deps" . liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) - let isType = isUpper $ head oldNameStr - rewrite = (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ T.unpack newRdrNameStr) - (_errors, retrieEdit@WorkspaceEdit{_changes}) <- - liftIO $ callRetrieWithTransformerAndUpdates - (referenceTransformer refs) - contextUpdater + refFiles <- mapM forceGetNfp (nub [uri | Location uri _ <- refs]) + + edits <- mapM (renameFile state refs (getOccString oldName) (T.unpack newNameText)) refFiles + pure $ WorkspaceEdit (Just $ foldl1 (HM.unionWith (<>)) edits) Nothing Nothing + +renameFile :: IdeState + -> [Location] + -> String + -> String + -> NormalizedFilePath + -> ExceptT String (LspT Config IO) WorkspaceEditMap +renameFile state refs oldNameStr newNameStr nfp = do + -- Rename LHS declarations / imports / exports + src <- handleMaybeM "parsed source" $ + liftIO $ runAction + "Rename.GetAnnotatedParsedModule" state - (hscEnv session) - [Right rewrite] - nfp - False + (use GetAnnotatedParsedSource nfp) + let sourceEdits = getSourceEdits refs (mkRdrUnqual $ mkTcOcc newNameStr) src - pure $ case declEdits of - [] -> WorkspaceEdit Nothing Nothing Nothing - declEdits' -> retrieEdit { - _changes = foldl1 (.) (map (uncurry $ HM.insertWith (<>)) declEdits') <$> _changes - } + -- Rename RHS with retrie + rhsEdits <- getRhsEdits state refs (getRewrite oldNameStr newNameStr) nfp + pure $ HM.insertWith (<>) (nfpToUri nfp) sourceEdits rhsEdits + +getRewrite :: String -> String -> RewriteSpec +getRewrite oldNameStr newNameStr = + (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ newNameStr) + where + isType = isUpper $ head oldNameStr ------------------------------------------------------------------------------- -- Source renaming -sourceEdits :: RdrName -> [Location] -> Annotated ParsedSource -> List TextEdit -sourceEdits newRdrName refs annPs = makeDiffTextEdit src res +getSourceEdits :: [Location] -> RdrName -> Annotated ParsedSource -> List TextEdit +getSourceEdits refs newRdrName annPs = do + makeDiffTextEdit src res where src = T.pack $ printA annPs updateMod = - updateImports newRdrName refs . - updateExports newRdrName refs . - updateLhsDecls newRdrName refs + updateImports refs newRdrName . + updateExports refs newRdrName . + updateLhsDecls refs newRdrName res = T.pack $ printA $ (fmap . fmap) updateMod annPs -updateImports :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs -updateImports newRdrName refs ps@HsModule{hsmodImports} = +updateImports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateImports refs newRdrName ps@HsModule{hsmodImports} = ps {hsmodImports = map (fmap renameImport) hsmodImports} where renameImport :: ImportDecl GhcPs -> ImportDecl GhcPs @@ -102,8 +101,8 @@ updateImports newRdrName refs ps@HsModule{hsmodImports} = } renameImport importDecl = importDecl -updateExports :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs -updateExports newRdrName refs ps@HsModule{hsmodExports} = +updateExports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateExports refs newRdrName ps@HsModule{hsmodExports} = ps {hsmodExports = (fmap . fmap) (map (fmap $ renameIE refs newRdrName)) hsmodExports} -- TODO: implement explicit type import/export renames @@ -121,8 +120,8 @@ renameIE refs newRdrName IEThingWith{} = error "not implemented explicit type import/export renames yet" renameIE _ _ export = export -updateLhsDecls :: RdrName -> [Location] -> HsModule GhcPs -> HsModule GhcPs -updateLhsDecls newRdrName refs ps@HsModule{hsmodDecls} = +updateLhsDecls :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateLhsDecls refs newRdrName ps@HsModule{hsmodDecls} = ps {hsmodDecls = map (fmap renameLhsDecl) hsmodDecls} where renameLhsDecl :: HsDecl GhcPs -> HsDecl GhcPs @@ -174,33 +173,43 @@ renameLhsMatch newRdrName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = match{m_ctxt = funRhs{mc_fun = fmap (const newRdrName) mc_fun}} renameLhsMatch _ _ = error "Expected function match" - ------------------------------------------------------------------------------- -- retrie +getRhsEdits :: IdeState -> [Location] -> RewriteSpec -> NormalizedFilePath -> ExceptT String (LspT Config IO) WorkspaceEditMap +getRhsEdits state refs rewriteSpec nfp = do + (session, _) <- handleMaybeM "session deps" $ liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) + (errors, WorkspaceEdit{_changes = edits}) <- + liftIO $ callRetrieWithTransformerAndUpdates + (referenceTransformer refs) + contextUpdater + state + (hscEnv session) + [Right rewriteSpec] + nfp + True + lift $ sendRetrieErrors errors + handleMaybe "retrie" edits + -- limits matches to reference locations referenceTransformer :: [Location] -> MatchResultTransformer referenceTransformer refs Context{ctxtBinders} match | MatchResult _sub template <- match - , trace ("\nRefs: " ++ show refs ++ "\nContext: " ++ show (map getRdrLoc ctxtBinders)) - any (containsRef . getRdrLoc) ctxtBinders = pure match + , any (containsRef . getRdrLoc) ctxtBinders = pure match | otherwise = pure NoMatch where containsRef srcSpan = any (flip isSubspanOf srcSpan . locToSpan) refs getRdrLoc (Exact name) = nameSrcSpan name getRdrLoc _ = error "Expected exact name" - -- Hacky use of ctxtBinders to track match spans contextUpdater :: (Typeable b, Monad f) => Context -> Int -> b -> f Context contextUpdater c@Context{ctxtBinders} i = const (pure c) `extQ` (return . updType) `extQ` (return . updExpr) - `extQ` (return . updMatch) `extQ` (return . updTyDecl) + `extQ` (return . updMatch) where - makeName = Exact . mkInternalName initTyVarUnique (mkVarOcc "") - updType :: LHsType GhcPs -> Context updType (L _ (HsAppTy _ (L matchSpan _) _)) = c {ctxtBinders = makeName matchSpan : ctxtBinders} @@ -213,11 +222,6 @@ contextUpdater c@Context{ctxtBinders} i = const (pure c) updExpr (L matchSpan _) = c {ctxtBinders = makeName matchSpan : ctxtBinders} - -- updTyDecl :: LTyClDecl GhcPs -> Context - -- updTyDecl (L matchSpan SynDecl{tcdLName}) = - -- c {ctxtBinders = makeName (matchSpan `subtractSrcSpans` getLoc tcdLName) : ctxtBinders} - -- updTyDecl (L _ _) = c - updTyDecl :: TyClDecl GhcPs -> Context updTyDecl SynDecl{tcdRhs} = c {ctxtBinders = makeName (getLoc tcdRhs) : ctxtBinders} @@ -228,67 +232,63 @@ contextUpdater c@Context{ctxtBinders} i = const (pure c) c {ctxtBinders = makeName (matchSpan `subtractSrcSpans` funNameSpan) : ctxtBinders} updMatch (L matchSpan _) = c {ctxtBinders = makeName matchSpan : ctxtBinders} -subtractSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -subtractSrcSpans span1 (RealSrcSpan span2) - = mkSrcSpan startLoc endLoc - where - startLoc = mkSrcLoc (srcSpanFile span2) (srcSpanStartLine span2) (srcSpanEndCol span2) - endLoc = srcSpanEnd span1 -subtractSrcSpans _ _ = error "" + makeName = Exact . mkInternalName initTyVarUnique (mkVarOcc "") ------------------------------------------------------------------------------- -- reference finding refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do + ShakeExtras{hiedb} <- getShakeExtras fois <- HM.keys <$> getFilesOfInterestUntracked Just asts <- sequence <$> usesWithStale GetHieAst fois let foiRefs = concat $ mapMaybe (getNameAstLocations name) asts - refs <- nameDbRefs fois name + Just mod = nameModule_maybe name + refs <- liftIO $ mapMaybe rowToLoc <$> findReferences + hiedb + True + (nameOccName name) + (Just $ moduleName mod) + (Just $ moduleUnitId mod) + (map fromNormalizedFilePath fois) pure $ nubOrd $ foiRefs ++ refs -nameDbRefs :: [NormalizedFilePath] -> Name -> Action [Location] -nameDbRefs fois name = do - ShakeExtras{hiedb} <- getShakeExtras - case nameModule_maybe name of - Nothing -> pure [] - Just mod -> do - let exclude = map fromNormalizedFilePath fois - rows <- liftIO $ findReferences - hiedb - True - (nameOccName name) - (Just $ moduleName mod) - (Just $ moduleUnitId mod) - exclude - pure $ mapMaybe rowToLoc rows - getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] getNameAstLocations name (HAR _ _ rm _ _, mapping) = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) <$> M.lookup (Right name) rm - ------------------------------------------------------------------------------- -- util -forceGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath -forceGetNfp nfp = handleMaybe "uri" $ toNormalizedFilePath <$> uriToFilePath nfp - -isTopLevelSpan :: SrcSpan -> Bool -isTopLevelSpan (RealSrcSpan srcSpan) = srcSpanStartCol srcSpan == 1 -isTopLevelSpan _ = False +nfpToUri :: NormalizedFilePath -> Uri +nfpToUri = filePathToUri . fromNormalizedFilePath -isListEmpty :: List a -> Bool -isListEmpty (List xs) = null xs +forceGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath +forceGetNfp uri = handleMaybe "uri" $ toNormalizedFilePath <$> uriToFilePath uri isRef :: Retrie.HasSrcSpan a => [Location] -> a -> Bool -isRef refs = isRef' refs . getLoc - -isRef' :: [Location] -> SrcSpan -> Bool -isRef' refs = (`elem` refs) . fromJust . srcSpanToLocation +isRef refs = (`elem` refs) . fromJust . srcSpanToLocation . getLoc locToSpan :: Location -> SrcSpan locToSpan (Location uri (Range (Position l c) (Position l' c'))) = mkSrcSpan (mkSrcLoc' uri (succ l) (succ c)) (mkSrcLoc' uri (succ l') (succ c')) where mkSrcLoc' = mkSrcLoc . mkFastString . fromJust . uriToFilePath + +longerThan :: Location -> Int -> Bool +longerThan (Location _ (Range Position{_character = start} Position{_character = end})) n = + end - start > n + +getNamesAtPos :: IdeState -> Position -> NormalizedFilePath -> ExceptT String (LspT Config IO) [Name] +getNamesAtPos state pos nfp = do + (HAR{hieAst}, mapping) <- handleMaybeM "ast" . liftIO . runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp + let oldName = getAstNamesAtPoint hieAst pos mapping + pure oldName + +subtractSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +subtractSrcSpans span1 (RealSrcSpan span2) + = mkSrcSpan startLoc endLoc + where + startLoc = mkSrcLoc (srcSpanFile span2) (srcSpanStartLine span2) (srcSpanEndCol span2) + endLoc = srcSpanEnd span1 +subtractSrcSpans _ _ = error "" diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 2ec5ffdb43..57bc6e3c2f 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -15,7 +15,7 @@ {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE RankNTypes #-} -module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, RunRetrieParams(..), response, handleMaybe, handleMaybeM) where +module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, RunRetrieParams(..), response, handleMaybe, handleMaybeM, sendRetrieErrors) where import Control.Concurrent.Extra (readVar) import Control.Exception.Safe (Exception (..), @@ -88,7 +88,7 @@ import Language.LSP.Server (LspM, ProgressCancellable (Cancellable), sendNotification, sendRequest, - withIndefiniteProgress) + withIndefiniteProgress, LspT, MonadLsp) import Language.LSP.Types as J import Retrie.CPP (CPP (NoCPP), parseCPP) import Retrie.Context (ContextUpdater, updateContext) @@ -157,16 +157,22 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = (map Right rewrites <> map Left importRewrites) nfp restrictToOriginatingFile - unless (null errors) $ - lift $ sendNotification SWindowShowMessage $ - ShowMessageParams MtWarning $ - T.unlines $ - "## Found errors during rewrite:" : - ["-" <> T.pack (show e) | e <- errors] + lift $ sendRetrieErrors errors + lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) return () return $ Right Null + +sendRetrieErrors :: (MonadLsp c f) => [CallRetrieError] -> f () +sendRetrieErrors errors = do + unless (null errors) $ + sendNotification SWindowShowMessage $ + ShowMessageParams MtWarning $ + T.unlines $ + "## Found errors during rewrite:" : + ["-" <> T.pack (show e) | e <- errors] + extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec] extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing) | Just FunBind {fun_matches} diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 565621d7ee..db0683991d 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -79,7 +79,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - - retrie-1.0.0.0 + - retrie-0.1.1.1 - semialign-1.1 - shake-0.19.4 - stylish-haskell-0.12.2.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index bbe6c651f3..658f601de0 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -80,7 +80,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - - retrie-1.0.0.0 + - retrie-0.1.1.1 - semialign-1.1 - shake-0.19.4 - stylish-haskell-0.12.2.0 From 392dc94f8df467a597fda7941299cb96da420ef5 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 14 Aug 2021 11:11:34 +0100 Subject: [PATCH 27/49] qualified renames --- .../src/Ide/Plugin/Rename.hs | 103 ++++++++++++------ plugins/hls-rename-plugin/test/Main.hs | 6 +- 2 files changed, 73 insertions(+), 36 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index c7bef6b846..6f3f42381a 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -31,7 +31,6 @@ import Language.LSP.Server import Language.LSP.Types hiding (_changes, _range) import Retrie hiding (HsModule, getLoc) import Retrie.SYB -import Control.Monad descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { @@ -40,7 +39,6 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) = response $ do - -- get reference locations nfp <- forceGetNfp uri oldName <- head <$> getNamesAtPos state pos nfp refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) @@ -49,7 +47,8 @@ renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _pr edits <- mapM (renameFile state refs (getOccString oldName) (T.unpack newNameText)) refFiles pure $ WorkspaceEdit (Just $ foldl1 (HM.unionWith (<>)) edits) Nothing Nothing -renameFile :: IdeState +renameFile :: + IdeState -> [Location] -> String -> String @@ -57,38 +56,47 @@ renameFile :: IdeState -> ExceptT String (LspT Config IO) WorkspaceEditMap renameFile state refs oldNameStr newNameStr nfp = do -- Rename LHS declarations / imports / exports - src <- handleMaybeM "parsed source" $ - liftIO $ runAction - "Rename.GetAnnotatedParsedModule" - state - (use GetAnnotatedParsedSource nfp) + src <- handleMaybeM "error: parsed source" $ + liftIO $ runAction + "Rename.GetAnnotatedParsedModule" + state + (use GetAnnotatedParsedSource nfp) let sourceEdits = getSourceEdits refs (mkRdrUnqual $ mkTcOcc newNameStr) src -- Rename RHS with retrie - rhsEdits <- getRhsEdits state refs (getRewrite oldNameStr newNameStr) nfp + Location originUri _ <- handleMaybe "error: could not find name origin" $ find containsDecl refs + originNfp <- forceGetNfp originUri + ParsedModule{pm_parsed_source = L _ HsModule{hsmodName}} <- + handleMaybeM "error: parsed source" $ + liftIO $ runAction + "Rename.GetAnnotatedParsedModule" + state + (use GetParsedModule originNfp) + L _ originModule <- handleMaybe "error: module name" hsmodName + + rewriteSpecs <- getRewriteSpecs state oldNameStr newNameStr originModule nfp + rhsEdits <- getRhsEdits state refs rewriteSpecs nfp pure $ HM.insertWith (<>) (nfpToUri nfp) sourceEdits rhsEdits -getRewrite :: String -> String -> RewriteSpec -getRewrite oldNameStr newNameStr = - (if isType then AdhocType else Adhoc) (oldNameStr ++ " = " ++ newNameStr) - where - isType = isUpper $ head oldNameStr - ------------------------------------------------------------------------------- -- Source renaming getSourceEdits :: [Location] -> RdrName -> Annotated ParsedSource -> List TextEdit -getSourceEdits refs newRdrName annPs = do +getSourceEdits refs newRdrName annPs = makeDiffTextEdit src res where src = T.pack $ printA annPs updateMod = - updateImports refs newRdrName . updateExports refs newRdrName . + updateImports refs newRdrName . updateLhsDecls refs newRdrName res = T.pack $ printA $ (fmap . fmap) updateMod annPs +updateExports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateExports refs newRdrName ps@HsModule{hsmodExports} = + ps {hsmodExports = (fmap . fmap) (map (fmap $ renameIE refs newRdrName)) hsmodExports} + updateImports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs updateImports refs newRdrName ps@HsModule{hsmodImports} = ps {hsmodImports = map (fmap renameImport) hsmodImports} @@ -101,10 +109,6 @@ updateImports refs newRdrName ps@HsModule{hsmodImports} = } renameImport importDecl = importDecl -updateExports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs -updateExports refs newRdrName ps@HsModule{hsmodExports} = - ps {hsmodExports = (fmap . fmap) (map (fmap $ renameIE refs newRdrName)) hsmodExports} - -- TODO: implement explicit type import/export renames renameIE :: [Location] -> RdrName -> IE GhcPs -> IE GhcPs renameIE refs newRdrName (IEVar xVar ieName) @@ -120,6 +124,7 @@ renameIE refs newRdrName IEThingWith{} = error "not implemented explicit type import/export renames yet" renameIE _ _ export = export +-- TODO: data constructor renames updateLhsDecls :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs updateLhsDecls refs newRdrName ps@HsModule{hsmodDecls} = ps {hsmodDecls = map (fmap renameLhsDecl) hsmodDecls} @@ -176,20 +181,48 @@ renameLhsMatch _ _ = error "Expected function match" ------------------------------------------------------------------------------- -- retrie -getRhsEdits :: IdeState -> [Location] -> RewriteSpec -> NormalizedFilePath -> ExceptT String (LspT Config IO) WorkspaceEditMap -getRhsEdits state refs rewriteSpec nfp = do - (session, _) <- handleMaybeM "session deps" $ liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) +getRhsEdits :: IdeState -> [Location] -> [RewriteSpec] -> NormalizedFilePath -> ExceptT String (LspT Config IO) WorkspaceEditMap +getRhsEdits state refs rewriteSpecs nfp = do + (session, _) <- handleMaybeM "error: session deps" $ liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) (errors, WorkspaceEdit{_changes = edits}) <- liftIO $ callRetrieWithTransformerAndUpdates (referenceTransformer refs) contextUpdater state (hscEnv session) - [Right rewriteSpec] + (map Right rewriteSpecs) nfp True lift $ sendRetrieErrors errors - handleMaybe "retrie" edits + handleMaybe "error: retrie" edits + +getRewriteSpecs :: + IdeState + -> String + -> String + -> ModuleName + -> NormalizedFilePath + -> ExceptT String (LspT Config IO) [RewriteSpec] +getRewriteSpecs state oldNameStr newNameStr originModule nfp = do + ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} <- + handleMaybeM "error: parsed source" $ + liftIO $ runAction + "Rename.GetAnnotatedParsedModule" + state + (use GetParsedModule nfp) + let rewriteType = (if isUpper $ head oldNameStr then AdhocType else Adhoc) + mbImportDecl = find ((==originModule) . unLoc . ideclName) (map unLoc hsmodImports) + mkAdhoc qualStr = rewriteType $ qualStr ++ oldNameStr ++ " = " ++ qualStr ++ newNameStr + unQualRewrite = mkAdhoc "" + pure $ case mbImportDecl of + Just decl@ImportDecl{ideclQualified = True} -> [mkAdhoc $ getQualifierStr decl] + Just decl -> [unQualRewrite, mkAdhoc $ getQualifierStr decl] + Nothing -> [unQualRewrite] + +getQualifierStr :: ImportDecl pass -> String +getQualifierStr ImportDecl{ideclAs, ideclName} = + moduleNameString (unLoc (fromMaybe ideclName ideclAs)) ++ "." +getQualifierStr _ = "" -- limits matches to reference locations referenceTransformer :: [Location] -> MatchResultTransformer @@ -210,6 +243,7 @@ contextUpdater c@Context{ctxtBinders} i = const (pure c) `extQ` (return . updTyDecl) `extQ` (return . updMatch) where + -- Todo: add statement matches updType :: LHsType GhcPs -> Context updType (L _ (HsAppTy _ (L matchSpan _) _)) = c {ctxtBinders = makeName matchSpan : ctxtBinders} @@ -241,17 +275,17 @@ refsAtName :: NormalizedFilePath -> Name -> Action [Location] refsAtName nfp name = do ShakeExtras{hiedb} <- getShakeExtras fois <- HM.keys <$> getFilesOfInterestUntracked - Just asts <- sequence <$> usesWithStale GetHieAst fois - let foiRefs = concat $ mapMaybe (getNameAstLocations name) asts + Just ast <- useWithStale GetHieAst nfp + let Just fileRefs = getNameAstLocations name ast Just mod = nameModule_maybe name - refs <- liftIO $ mapMaybe rowToLoc <$> findReferences + dbRefs <- liftIO $ mapMaybe rowToLoc <$> findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) - (map fromNormalizedFilePath fois) - pure $ nubOrd $ foiRefs ++ refs + [fromNormalizedFilePath nfp] + pure $ nubOrd $ fileRefs ++ dbRefs getNameAstLocations :: Name -> (HieAstResult, PositionMapping) -> Maybe [Location] getNameAstLocations name (HAR _ _ rm _ _, mapping) = @@ -264,7 +298,7 @@ nfpToUri :: NormalizedFilePath -> Uri nfpToUri = filePathToUri . fromNormalizedFilePath forceGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath -forceGetNfp uri = handleMaybe "uri" $ toNormalizedFilePath <$> uriToFilePath uri +forceGetNfp uri = handleMaybe "error: uri" $ toNormalizedFilePath <$> uriToFilePath uri isRef :: Retrie.HasSrcSpan a => [Location] -> a -> Bool isRef refs = (`elem` refs) . fromJust . srcSpanToLocation . getLoc @@ -281,7 +315,7 @@ longerThan (Location _ (Range Position{_character = start} Position{_character = getNamesAtPos :: IdeState -> Position -> NormalizedFilePath -> ExceptT String (LspT Config IO) [Name] getNamesAtPos state pos nfp = do - (HAR{hieAst}, mapping) <- handleMaybeM "ast" . liftIO . runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp + (HAR{hieAst}, mapping) <- handleMaybeM "error: ast" . liftIO . runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp let oldName = getAstNamesAtPoint hieAst pos mapping pure oldName @@ -292,3 +326,6 @@ subtractSrcSpans span1 (RealSrcSpan span2) startLoc = mkSrcLoc (srcSpanFile span2) (srcSpanStartLine span2) (srcSpanEndCol span2) endLoc = srcSpanEnd span1 subtractSrcSpans _ _ = error "" + +containsDecl :: Location -> Bool +containsDecl (Location _ Range{_start = Position{_character}}) = _character == 0 diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 72d319849a..13c37fae48 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -35,15 +35,15 @@ tests = testGroup "rename" , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do rename doc (Position 1 1) "baz" + , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ + goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do + rename doc (Position 3 12) "baz" , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do rename doc (Position 2 15) "BinaryTree" , expectFailBecause "Not implemented yet" $ goldenWithRename "data constructor" "DataConstructor" $ \doc -> do rename doc (Position 0 13) "Apply" - , expectFailBecause "qualified rename not implemented yet" $ - goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do - rename doc (Position 3 12) "baz" ] , testGroup "non Top-level renames" [ expectFailBecause "Only top-level renames are implemented" $ From 93d41fe4100e2a2d964cb01d38f482d5e493e870 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 14 Aug 2021 12:31:15 +0100 Subject: [PATCH 28/49] fix: use isQualifiedImport to test for qualified --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 6f3f42381a..74894834c6 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -215,9 +215,10 @@ getRewriteSpecs state oldNameStr newNameStr originModule nfp = do mkAdhoc qualStr = rewriteType $ qualStr ++ oldNameStr ++ " = " ++ qualStr ++ newNameStr unQualRewrite = mkAdhoc "" pure $ case mbImportDecl of - Just decl@ImportDecl{ideclQualified = True} -> [mkAdhoc $ getQualifierStr decl] - Just decl -> [unQualRewrite, mkAdhoc $ getQualifierStr decl] - Nothing -> [unQualRewrite] + Just decl -> if isQualifiedImport decl + then [mkAdhoc $ getQualifierStr decl] + else [unQualRewrite, mkAdhoc $ getQualifierStr decl] + Nothing -> [unQualRewrite] getQualifierStr :: ImportDecl pass -> String getQualifierStr ImportDecl{ideclAs, ideclName} = From 545e1aa4b1ffdeb2c62bf33bd33b436973d18714 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 14 Aug 2021 18:59:37 +0100 Subject: [PATCH 29/49] bump retrie version in stack for ghc 8.6.* --- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index db0683991d..565621d7ee 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -79,7 +79,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - semialign-1.1 - shake-0.19.4 - stylish-haskell-0.12.2.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 658f601de0..bbe6c651f3 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -80,7 +80,7 @@ extra-deps: - regex-base-0.94.0.0 - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - - retrie-0.1.1.1 + - retrie-1.0.0.0 - semialign-1.1 - shake-0.19.4 - stylish-haskell-0.12.2.0 From e9e29200e4569c2075c45edf1cbaae766c85afaf Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 14 Aug 2021 20:53:00 +0100 Subject: [PATCH 30/49] code style --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index ed8a5b13d3..8cedc86a47 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -183,7 +183,8 @@ renameLhsMatch _ _ = error "Expected function match" getRhsEdits :: IdeState -> [Location] -> [RewriteSpec] -> NormalizedFilePath -> ExceptT String (LspT Config IO) WorkspaceEditMap getRhsEdits state refs rewriteSpecs nfp = do - (session, _) <- handleMaybeM "error: session deps" $ liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) + (session, _) <- handleMaybeM "error: session deps" $ + liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) (errors, WorkspaceEdit{_changes = edits}) <- liftIO $ callRetrieWithTransformerAndUpdates (referenceTransformer refs) @@ -316,16 +317,17 @@ longerThan (Location _ (Range Position{_character = start} Position{_character = getNamesAtPos :: IdeState -> Position -> NormalizedFilePath -> ExceptT String (LspT Config IO) [Name] getNamesAtPos state pos nfp = do - (HAR{hieAst}, mapping) <- handleMaybeM "error: ast" . liftIO . runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp + (HAR{hieAst}, mapping) <- handleMaybeM "error: ast" $ + liftIO $ runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp let oldName = getAstNamesAtPoint hieAst pos mapping pure oldName subtractSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -subtractSrcSpans span1 (RealSrcSpan span2) +subtractSrcSpans minuend (RealSrcSpan subtrahend) = mkSrcSpan startLoc endLoc where - startLoc = mkSrcLoc (srcSpanFile span2) (srcSpanStartLine span2) (srcSpanEndCol span2) - endLoc = srcSpanEnd span1 + startLoc = mkSrcLoc (srcSpanFile subtrahend) (srcSpanStartLine subtrahend) (srcSpanEndCol subtrahend) + endLoc = srcSpanEnd minuend subtractSrcSpans _ _ = error "" refContainsDecl :: Location -> Bool From 68275445ed43046b37fd12bb65f4f37efccf2973 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 15 Aug 2021 00:00:11 +0100 Subject: [PATCH 31/49] disable for ghc 8.6.5/8.6.4/9.0.1 --- cabal-ghc901.project | 2 +- haskell-language-server.cabal | 2 +- plugins/hls-rename-plugin/hls-rename-plugin.cabal | 4 +++- plugins/hls-rename-plugin/test/Main.hs | 2 +- stack-9.0.1.yaml | 2 +- 5 files changed, 7 insertions(+), 5 deletions(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 1396db52b6..0c605283a8 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -15,7 +15,7 @@ packages: ./plugins/hls-explicit-imports-plugin ./plugins/hls-refine-imports-plugin ./plugins/hls-hlint-plugin - ./plugins/hls-rename-plugin + -- ./plugins/hls-rename-plugin ./plugins/hls-retrie-plugin ./plugins/hls-haddock-comments-plugin -- ./plugins/hls-splice-plugin diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index e25441ba5a..13fde17c26 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -229,7 +229,7 @@ common refineImports cpp-options: -DrefineImports common rename - if flag(rename) || flag(all-plugins) + if impl(ghc >= 8.8) && flag(rename) || flag(all-plugins) build-depends: hls-rename-plugin ^>= 1.0.0.0 cpp-options: -Drename diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 09de8847e2..4bf1871f01 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -26,7 +26,6 @@ library , lsp , hls-plugin-api ^>=1.2 , ghcide >=1.4 && <1.5 - , retrie >0.1.1.1 , transformers , hls-retrie-plugin >= 1.0.1.1 , text @@ -36,6 +35,9 @@ library , hiedb , ghc-exactprint + if impl(ghc >= 8.8) + build-depends: retrie >=1.0.0.0 + default-language: Haskell2010 test-suite tests diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 13c37fae48..dd724e1403 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -59,7 +59,7 @@ tests = testGroup "rename" ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithRename title path = +goldenWithRename title path = requiresRenamePlugin $ goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" testDataDir :: FilePath diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 121d2ee515..4c3ebab746 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -16,7 +16,7 @@ packages: - ./plugins/hls-explicit-imports-plugin # - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - - ./plugins/hls-rename-plugin + # - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin # - ./plugins/hls-splice-plugin # - ./plugins/hls-tactics-plugin From 57f4b45df16d0a8420f42c1b612797006bee7ba4 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 15 Aug 2021 00:38:59 +0100 Subject: [PATCH 32/49] add rename to stack 8.6.* package list --- stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + 2 files changed, 2 insertions(+) diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 8129910681..20601aea67 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -16,6 +16,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin + - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - ./plugins/hls-tactics-plugin diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index f012979944..0cce8fe49e 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -15,6 +15,7 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin + - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - ./plugins/hls-tactics-plugin From 373ac3de6c4587b980ca4ed4c62352faa27a3a1c Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sun, 15 Aug 2021 01:26:50 +0100 Subject: [PATCH 33/49] update nix config with plugin --- cabal-ghc901.project | 2 +- configuration-ghc-901.nix | 2 ++ stack-9.0.1.yaml | 1 + 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 0c605283a8..36b02a8034 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -80,7 +80,7 @@ index-state: 2021-08-08T02:21:16Z constraints: -- These plugins doesn't work on GHC9 yet - haskell-language-server -brittany -class -fourmolu -splice -stylishhaskell -tactic -refineImports + haskell-language-server -brittany -class -fourmolu -splice -stylishhaskell -tactic -refineImports -rename allow-newer: diff --git a/configuration-ghc-901.nix b/configuration-ghc-901.nix index 7f3d38554c..aca5b1a5b1 100644 --- a/configuration-ghc-901.nix +++ b/configuration-ghc-901.nix @@ -7,6 +7,7 @@ let "hls-brittany-plugin" "hls-stylish-haskell-plugin" "hls-fourmolu-plugin" + "hls-rename-plugin" "hls-splice-plugin" "hls-class-plugin" "hls-refine-imports-plugin" @@ -91,6 +92,7 @@ let "-f-brittany" "-f-class" "-f-fourmolu" + "-f-rename" "-f-splice" "-f-stylishhaskell" "-f-tactic" diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 4c3ebab746..f0a5668051 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -110,6 +110,7 @@ flags: pedantic: true class: false splice: false + rename: false refineImports: false tactic: false # Dependencies fail From abe3e2d347f4349271d473e2fb314cd7c853ec47 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 00:13:43 +0100 Subject: [PATCH 34/49] extra test cases, test consistency, code style --- .../src/Ide/Plugin/Rename.hs | 176 ++++++++---------- plugins/hls-rename-plugin/test/Main.hs | 55 +++--- .../test/testdata/ImportHiding.expected.hs | 4 + .../test/testdata/ImportHiding.hs | 4 + .../test/testdata/QualifiedAs.expected.hs | 4 + .../test/testdata/QualifiedAs.hs | 4 + .../testdata/QualifiedShadowing.expected.hs | 7 + .../test/testdata/QualifiedShadowing.hs | 7 + .../hls-rename-plugin/test/testdata/hie.yaml | 3 + .../src/Ide/Plugin/Retrie.hs | 12 +- 10 files changed, 146 insertions(+), 130 deletions(-) create mode 100644 plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/ImportHiding.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs create mode 100644 plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 8cedc86a47..63f991dc7e 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -4,6 +4,7 @@ module Ide.Plugin.Rename (descriptor) where +import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except @@ -39,59 +40,49 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) = response $ do - nfp <- forceGetNfp uri + nfp <- safeGetNfp uri oldName <- head <$> getNamesAtPos state pos nfp refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) - refFiles <- mapM forceGetNfp (nub [uri | Location uri _ <- refs]) + refFiles <- mapM safeGetNfp (nub [uri | Location uri _ <- refs]) + let newNameStr = T.unpack newNameText + newRdrName = mkRdrUnqual $ mkTcOcc newNameStr - edits <- mapM (renameFile state refs (getOccString oldName) (T.unpack newNameText)) refFiles - pure $ WorkspaceEdit (Just $ foldl1 (HM.unionWith (<>)) edits) Nothing Nothing + -- Rename Imports / Export + let updateIe = updateExports refs newRdrName . updateImports refs newRdrName + ieFileEdits <- mapMToSnd (getSrcEdits state updateIe) refFiles -renameFile :: - IdeState - -> [Location] - -> String - -> String - -> NormalizedFilePath - -> ExceptT String (LspT Config IO) WorkspaceEditMap -renameFile state refs oldNameStr newNameStr nfp = do - -- Rename LHS declarations / imports / exports - src <- handleMaybeM "error: parsed source" $ - liftIO $ runAction - "Rename.GetAnnotatedParsedModule" - state - (use GetAnnotatedParsedSource nfp) - let sourceEdits = getSourceEdits refs (mkRdrUnqual $ mkTcOcc newNameStr) src + -- Rename left-hand sides (declarations) + filesDeclEdits <- mapMToSnd (getSrcEdits state (updateLhsDecls refs newRdrName)) refFiles + declEdits@(originNfp, _) <- handleMaybe "error: could not find name declaration" $ + find (\(_, List xs) -> not $ null xs) filesDeclEdits - -- Rename RHS with retrie - Location originUri _ <- handleMaybe "error: could not find name origin" $ find refContainsDecl refs - originNfp <- forceGetNfp originUri - ParsedModule{pm_parsed_source = L _ HsModule{hsmodName}} <- - handleMaybeM "error: parsed source" $ - liftIO $ runAction - "Rename.GetAnnotatedParsedModule" - state - (use GetParsedModule originNfp) - L _ originModule <- handleMaybe "error: module name" hsmodName + -- Rename right-hand sides (using retrie) + rhsEditMap <- foldl1 (HM.unionWith (<>)) <$> + mapM (getRhsEdits state refs oldName newNameStr originNfp) refFiles - rewriteSpecs <- getRewriteSpecs state oldNameStr newNameStr originModule nfp - rhsEdits <- getRhsEdits state refs rewriteSpecs nfp + -- combine edits + let insertEdits (nfp, edits) = HM.insertWith (<>) (nfpToUri nfp) edits + edits = foldr insertEdits rhsEditMap (declEdits : ieFileEdits) - pure $ HM.insertWith (<>) (nfpToUri nfp) sourceEdits rhsEdits + pure $ WorkspaceEdit (Just edits) Nothing Nothing ------------------------------------------------------------------------------- -- Source renaming -getSourceEdits :: [Location] -> RdrName -> Annotated ParsedSource -> List TextEdit -getSourceEdits refs newRdrName annPs = - makeDiffTextEdit src res - where - src = T.pack $ printA annPs - updateMod = - updateExports refs newRdrName . - updateImports refs newRdrName . - updateLhsDecls refs newRdrName +getSrcEdits :: + IdeState + -> (HsModule GhcPs -> HsModule GhcPs) + -> NormalizedFilePath + -> ExceptT String (LspT Config IO) (List TextEdit) +getSrcEdits state updateMod nfp = do + annPs <- handleMaybeM "error: parsed source" $ + liftIO $ runAction + "Rename.GetAnnotatedParsedModule" + state + (use GetAnnotatedParsedSource nfp) + let src = T.pack $ printA annPs res = T.pack $ printA $ (fmap . fmap) updateMod annPs + pure $ makeDiffTextEdit src res updateExports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs updateExports refs newRdrName ps@HsModule{hsmodExports} = @@ -131,58 +122,49 @@ updateLhsDecls refs newRdrName ps@HsModule{hsmodDecls} = where renameLhsDecl :: HsDecl GhcPs -> HsDecl GhcPs renameLhsDecl (SigD xSig (TypeSig xTySig sigNames wc)) = - SigD xSig $ TypeSig xTySig (map renameRdrName sigNames) wc + SigD xSig $ TypeSig xTySig (map renameRdrName' sigNames) wc renameLhsDecl (ValD xVal funBind@FunBind{fun_id, fun_matches = fun_matches@MG{mg_alts}}) - | isRef refs fun_id = ValD xVal $ funBind { - fun_id = fmap (const newRdrName) fun_id, + = ValD xVal $ funBind { + fun_id = renameRdrName' fun_id, fun_matches = fun_matches {mg_alts = fmap (map (fmap $ renameLhsMatch newRdrName)) mg_alts} } renameLhsDecl (TyClD xTy dataDecl@DataDecl{tcdLName, tcdDataDefn = hsDataDefn@HsDataDefn{dd_cons}}) - | isRef refs tcdLName = TyClD xTy $ dataDecl { - tcdLName = fmap (const newRdrName) tcdLName, - tcdDataDefn = hsDataDefn {dd_cons = map (fmap renameCon) dd_cons} + = TyClD xTy $ dataDecl { + tcdLName = renameRdrName' tcdLName } renameLhsDecl (TyClD xTy synDecl@SynDecl{tcdLName}) - | isRef refs tcdLName = TyClD xTy $ synDecl { - tcdLName = fmap (const newRdrName) tcdLName + = TyClD xTy $ synDecl { + tcdLName = renameRdrName' tcdLName } renameLhsDecl decl = decl - renameCon :: ConDecl GhcPs -> ConDecl GhcPs - renameCon conDecl = case conDecl of - cdGast@ConDeclGADT{con_args} -> cdGast {con_args = renameConArgs con_args} - cdH98@ConDeclH98{con_args} -> cdH98 {con_args = renameConArgs con_args} - xCd@(XConDecl _) -> xCd - - renameConArgs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs - renameConArgs (PrefixCon args) = PrefixCon $ map (fmap renameBang) args - renameConArgs (InfixCon a1 a2) = InfixCon (fmap renameBang a1) (fmap renameBang a2) - renameConArgs (RecCon record) = RecCon $ fmap (map (fmap renameField)) record - - renameBang :: BangType GhcPs -> BangType GhcPs - renameBang (HsTyVar xTyVar p name) = HsTyVar xTyVar p $ renameRdrName name - renameBang _ = error "Expected type var" + renameRdrName' :: Located RdrName -> Located RdrName + renameRdrName' = renameRdrName refs newRdrName - renameField :: ConDeclField GhcPs -> ConDeclField GhcPs - renameField conDeclField@ConDeclField{cd_fld_type} = - conDeclField {cd_fld_type = fmap renameBang cd_fld_type} - renameField _ = error "Expected constructor declaration field" + renameLhsMatch :: RdrName -> Match GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs) + renameLhsMatch newRdrName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = + match{m_ctxt = funRhs{mc_fun = renameRdrName refs newRdrName mc_fun}} + renameLhsMatch _ _ = error "Expected function match" - renameRdrName :: Located RdrName -> Located RdrName - renameRdrName rdrName - | isRef refs rdrName = fmap (const newRdrName) rdrName - | otherwise = rdrName -renameLhsMatch :: RdrName -> Match GhcPs (LHsExpr GhcPs) -> Match GhcPs (LHsExpr GhcPs) -renameLhsMatch newRdrName match@Match{m_ctxt = funRhs@FunRhs{mc_fun}} = - match{m_ctxt = funRhs{mc_fun = fmap (const newRdrName) mc_fun}} -renameLhsMatch _ _ = error "Expected function match" +renameRdrName :: [Location] -> RdrName -> Located RdrName -> Located RdrName +renameRdrName refs newRdrName oldRdrName + | isRef refs oldRdrName = fmap (const newRdrName) oldRdrName + | otherwise = oldRdrName ------------------------------------------------------------------------------- -- retrie -getRhsEdits :: IdeState -> [Location] -> [RewriteSpec] -> NormalizedFilePath -> ExceptT String (LspT Config IO) WorkspaceEditMap -getRhsEdits state refs rewriteSpecs nfp = do +getRhsEdits :: + IdeState + -> [Location] + -> Name + -> String + -> NormalizedFilePath + -> NormalizedFilePath + -> ExceptT String (LspT Config IO) WorkspaceEditMap +getRhsEdits state refs oldName newNameStr originNfp nfp = do + rewriteSpecs <- getRewriteSpecs state (getOccString oldName) newNameStr originNfp nfp (session, _) <- handleMaybeM "error: session deps" $ liftIO $ runAction "Rename.GhcSessionDeps" state (useWithStale GhcSessionDeps nfp) (errors, WorkspaceEdit{_changes = edits}) <- @@ -201,24 +183,32 @@ getRewriteSpecs :: IdeState -> String -> String - -> ModuleName + -> NormalizedFilePath -> NormalizedFilePath -> ExceptT String (LspT Config IO) [RewriteSpec] -getRewriteSpecs state oldNameStr newNameStr originModule nfp = do +getRewriteSpecs state oldNameStr newNameStr originNfp nfp = do + ParsedModule{pm_parsed_source = L _ HsModule{hsmodName = mbOriginModule}} <- + handleMaybeM "error: parsed source" $ + liftIO $ runAction + "Rename.GetAnnotatedParsedModule" + state + (use GetParsedModule originNfp) ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} <- handleMaybeM "error: parsed source" $ liftIO $ runAction "Rename.GetAnnotatedParsedModule" state (use GetParsedModule nfp) - let rewriteType = (if isUpper $ head oldNameStr then AdhocType else Adhoc) - mbImportDecl = find ((==originModule) . unLoc . ideclName) (map unLoc hsmodImports) - mkAdhoc qualStr = rewriteType $ qualStr ++ oldNameStr ++ " = " ++ qualStr ++ newNameStr - unQualRewrite = mkAdhoc "" - pure $ case mbImportDecl of - Just decl -> if isQualifiedImport decl - then [mkAdhoc $ getQualifierStr decl] - else [unQualRewrite, mkAdhoc $ getQualifierStr decl] + let getNameImport (L _ originModule) = find ((==originModule) . unLoc . ideclName) (map unLoc hsmodImports) + mkRewriteSpec qualStr = (if isUpper $ head oldNameStr then AdhocType else Adhoc) $ + qualStr ++ oldNameStr ++ " = " ++ qualStr ++ newNameStr + mkQualRewrite = mkRewriteSpec . getQualifierStr + unQualRewrite = mkRewriteSpec "" + pure $ case getNameImport =<< mbOriginModule of + Just nameImport -> + if isQualifiedImport nameImport + then [mkQualRewrite nameImport] + else [unQualRewrite, mkQualRewrite nameImport] Nothing -> [unQualRewrite] getQualifierStr :: ImportDecl pass -> String @@ -299,8 +289,8 @@ getNameAstLocations name (HAR _ _ rm _ _, mapping) = nfpToUri :: NormalizedFilePath -> Uri nfpToUri = filePathToUri . fromNormalizedFilePath -forceGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath -forceGetNfp uri = handleMaybe "error: uri" $ toNormalizedFilePath <$> uriToFilePath uri +safeGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath +safeGetNfp uri = handleMaybe "error: uri" $ toNormalizedFilePath <$> uriToFilePath uri isRef :: Retrie.HasSrcSpan a => [Location] -> a -> Bool isRef refs = (`elem` refs) . fromJust . srcSpanToLocation . getLoc @@ -311,10 +301,6 @@ locToSpan (Location uri (Range (Position l c) (Position l' c'))) = where mkSrcLoc' = mkSrcLoc . mkFastString . fromJust . uriToFilePath -longerThan :: Location -> Int -> Bool -longerThan (Location _ (Range Position{_character = start} Position{_character = end})) n = - end - start > n - getNamesAtPos :: IdeState -> Position -> NormalizedFilePath -> ExceptT String (LspT Config IO) [Name] getNamesAtPos state pos nfp = do (HAR{hieAst}, mapping) <- handleMaybeM "error: ast" $ @@ -330,5 +316,5 @@ subtractSrcSpans minuend (RealSrcSpan subtrahend) endLoc = srcSpanEnd minuend subtractSrcSpans _ _ = error "" -refContainsDecl :: Location -> Bool -refContainsDecl (Location _ (Range Position{_character} _)) = _character == 0 +mapMToSnd :: Monad f => (a -> f b) -> [a] -> f [(a, b)] +mapMToSnd = liftM2 (<$>) zip . mapM diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index dd724e1403..5a5d542ccf 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -14,53 +14,52 @@ renamePlugin = Rename.descriptor "rename" tests :: TestTree tests = testGroup "rename" [ testGroup "Top-level renames" - [ ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "function name" "FunctionName" $ \doc -> do + [ goldenWithRename "function name" "FunctionName" $ \doc -> do rename doc (Position 3 1) "baz" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "GADT" "Gadt" $ \doc -> do + , goldenWithRename "GADT" "Gadt" $ \doc -> do rename doc (Position 6 37) "Expr" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "imported function" "ImportedFunction" $ \doc -> do + , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do rename doc (Position 3 8) "baz" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "exported function" "ExportedFunction" $ \doc -> do + , goldenWithRename "exported function" "ExportedFunction" $ \doc -> do rename doc (Position 2 1) "quux" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "hidden function" "HiddenFunction" $ \doc -> do + , goldenWithRename "hidden function" "HiddenFunction" $ \doc -> do rename doc (Position 0 32) "quux" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "allign indentation" "Indentation" $ \doc -> do + , goldenWithRename "allign indentation" "Indentation" $ \doc -> do rename doc (Position 0 2) "fooBarQuux" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do + , goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do rename doc (Position 1 1) "baz" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do + , goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do rename doc (Position 3 12) "baz" - , ignoreTestBecause "Inconsistent - need to wait for typecheck" $ - goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do - rename doc (Position 2 15) "BinaryTree" + , expectFailBecause "Bug: Test case giving different result to editor" $ + goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do + rename doc (Position 2 17) "BinaryTree" , expectFailBecause "Not implemented yet" $ goldenWithRename "data constructor" "DataConstructor" $ \doc -> do rename doc (Position 0 13) "Apply" + , goldenWithRename "import hiding" "ImportHiding" $ \doc -> do + rename doc (Position 0 22) "hiddenFoo" + , goldenWithRename "qualified as" "QualifiedAs" $ \doc -> do + rename doc (Position 3 10) "baz" + , goldenWithRename "qualified shadowing" "QualifiedShadowing" $ \doc -> do + rename doc (Position 3 12) "foobar" ] - , testGroup "non Top-level renames" - [ expectFailBecause "Only top-level renames are implemented" $ - goldenWithRename "function argument" "FunctionArgument" $ \doc -> do + , expectFailBecause "Only top-level renames are implemented" $ + testGroup "non Top-level renames" + [ goldenWithRename "function argument" "FunctionArgument" $ \doc -> do rename doc (Position 3 4) "y" - , expectFailBecause "Only top-level renames are implemented" $ - goldenWithRename "record field" "RecordField" $ \doc -> do + , goldenWithRename "record field" "RecordField" $ \doc -> do rename doc (Position 6 9) "number" - , expectFailBecause "Only top-level renames are implemented" $ - goldenWithRename "type variable" "TypeVariable" $ \doc -> do + , goldenWithRename "type variable" "TypeVariable" $ \doc -> do rename doc (Position 0 13) "b" ] ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithRename title path = requiresRenamePlugin $ - goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" +goldenWithRename title path act = + goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" $ \doc -> do + waitForProgressDone + waitForProgressDone + act doc testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs b/plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs new file mode 100644 index 0000000000..e1b600aa1c --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportHiding.expected.hs @@ -0,0 +1,4 @@ +import Foo hiding (hiddenFoo) + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/ImportHiding.hs b/plugins/hls-rename-plugin/test/testdata/ImportHiding.hs new file mode 100644 index 0000000000..c14099e68b --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/ImportHiding.hs @@ -0,0 +1,4 @@ +import Foo hiding (foo) + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs new file mode 100644 index 0000000000..a864119ef2 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.expected.hs @@ -0,0 +1,4 @@ +import qualified Foo as F + +bar :: Int -> Int +bar = F.baz diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs new file mode 100644 index 0000000000..022b2f8e31 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedAs.hs @@ -0,0 +1,4 @@ +import qualified Foo as F + +bar :: Int -> Int +bar = F.foo diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs new file mode 100644 index 0000000000..52dbcea2b0 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.expected.hs @@ -0,0 +1,7 @@ +import qualified Foo as F + +bar :: Int -> Int +bar x = F.foobar x + foo x + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs new file mode 100644 index 0000000000..aa5e50caf6 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/QualifiedShadowing.hs @@ -0,0 +1,7 @@ +import qualified Foo as F + +bar :: Int -> Int +bar x = F.foo x + foo x + +foo :: Int -> Int +foo _ = 5 diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml index d52005a4cb..166bde871f 100644 --- a/plugins/hls-rename-plugin/test/testdata/hie.yaml +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -15,3 +15,6 @@ cradle: - "Gadt" - "Indentation" - "Foo" + - "ImportHiding" + - "QualifiedAs" + - "QualifiedShadowing" diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 59e4a661dd..5d03fe4133 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -15,7 +15,7 @@ {-# OPTIONS -Wno-orphans #-} {-# LANGUAGE RankNTypes #-} -module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, RunRetrieParams(..), response, handleMaybe, handleMaybeM, sendRetrieErrors) where +module Ide.Plugin.Retrie (descriptor, callRetrieWithTransformerAndUpdates, response, handleMaybe, handleMaybeM, sendRetrieErrors) where import Control.Concurrent.Extra (readVar) import Control.Exception.Safe (Exception (..), @@ -43,12 +43,10 @@ import Data.Hashable (unhashed) import Data.IORef.Extra (atomicModifyIORef'_, newIORef, readIORef) import Data.List.Extra (find, nubOrdOn) -import Data.Maybe (fromMaybe) import Data.String (IsString (fromString)) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable (Typeable) -import Debug.Trace (trace) import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping import Development.IDE.Core.Shake (ShakeExtras (knownTargetsVar), @@ -84,18 +82,18 @@ import GhcPlugins (Outputable, import HsBinds import Ide.PluginUtils import Ide.Types -import Language.LSP.Server (LspM, +import Language.LSP.Server (LspM, MonadLsp, ProgressCancellable (Cancellable), sendNotification, sendRequest, - withIndefiniteProgress, - MonadLsp) + withIndefiniteProgress) import Language.LSP.Types as J hiding (SemanticTokenAbsolute (length, line), SemanticTokenRelative (length), SemanticTokensEdit (_start)) import Retrie.CPP (CPP (NoCPP), parseCPP) -import Retrie.Context (ContextUpdater, updateContext) +import Retrie.Context (ContextUpdater, + updateContext) import Retrie.ExactPrint (fix, relativiseApiAnns, transformA, unsafeMkA) import Retrie.Fixity (mkFixityEnv) From 03693f2a1f5867f80603abcd8e2bd6b5cbafda13 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 03:18:19 +0100 Subject: [PATCH 35/49] return response error fro ghc < 8.8 --- .../hls-rename-plugin/src/Ide/Plugin/Rename.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 63f991dc7e..32dffd9146 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} module Ide.Plugin.Rename (descriptor) where @@ -30,12 +30,20 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types hiding (_changes, _range) + +#if MIN_VERSION_ghc(8,0,0) import Retrie hiding (HsModule, getLoc) import Retrie.SYB +#endif descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { - pluginHandlers = mkPluginHandler STextDocumentRename renameProvider + pluginHandlers = mkPluginHandler STextDocumentRename +#if MIN_VERSION_ghc(8,0,0) + renameProvider +#else + (\_ _ _ -> pure $ Left $ ResponseError InternalError (T.pack "Rename plugin unsupported for ghc < 8.8.0") Nothing) +#endif } renameProvider :: PluginMethodHandler IdeState TextDocumentRename @@ -314,7 +322,7 @@ subtractSrcSpans minuend (RealSrcSpan subtrahend) where startLoc = mkSrcLoc (srcSpanFile subtrahend) (srcSpanStartLine subtrahend) (srcSpanEndCol subtrahend) endLoc = srcSpanEnd minuend -subtractSrcSpans _ _ = error "" +subtractSrcSpans _ _ = error "Expected real SrcSpan" mapMToSnd :: Monad f => (a -> f b) -> [a] -> f [(a, b)] mapMToSnd = liftM2 (<$>) zip . mapM From e0206ae1911b981c5e9869df99139d0bf721d9f3 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 05:45:27 +0100 Subject: [PATCH 36/49] remove response error for ghc <8.8.0 --- haskell-language-server.cabal | 2 +- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 7 ------- 2 files changed, 1 insertion(+), 8 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 13fde17c26..07fdf7a069 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -229,7 +229,7 @@ common refineImports cpp-options: -DrefineImports common rename - if impl(ghc >= 8.8) && flag(rename) || flag(all-plugins) + if impl(ghc >= 8.8) && (flag(rename) || flag(all-plugins)) build-depends: hls-rename-plugin ^>= 1.0.0.0 cpp-options: -Drename diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 32dffd9146..2abb56dc1e 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} @@ -30,20 +29,14 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types hiding (_changes, _range) - -#if MIN_VERSION_ghc(8,0,0) import Retrie hiding (HsModule, getLoc) import Retrie.SYB -#endif descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { pluginHandlers = mkPluginHandler STextDocumentRename -#if MIN_VERSION_ghc(8,0,0) renameProvider -#else (\_ _ _ -> pure $ Left $ ResponseError InternalError (T.pack "Rename plugin unsupported for ghc < 8.8.0") Nothing) -#endif } renameProvider :: PluginMethodHandler IdeState TextDocumentRename From e1f2454ac212cdef3cfd2ab5638e93c85177b7cb Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 06:31:12 +0100 Subject: [PATCH 37/49] fix: remove second renameProvider --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 2abb56dc1e..8db96c6583 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -34,9 +34,7 @@ import Retrie.SYB descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { - pluginHandlers = mkPluginHandler STextDocumentRename - renameProvider - (\_ _ _ -> pure $ Left $ ResponseError InternalError (T.pack "Rename plugin unsupported for ghc < 8.8.0") Nothing) + pluginHandlers = mkPluginHandler STextDocumentRename renameProvider } renameProvider :: PluginMethodHandler IdeState TextDocumentRename @@ -101,7 +99,7 @@ updateImports refs newRdrName ps@HsModule{hsmodImports} = } renameImport importDecl = importDecl --- TODO: implement explicit type import/export renames +-- TODO: implement explicit type import/export renameIE :: [Location] -> RdrName -> IE GhcPs -> IE GhcPs renameIE refs newRdrName (IEVar xVar ieName) | isRef refs ieName = From 4197543eecf47827026f6730f2da74bd03d89f2d Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 12:52:24 +0100 Subject: [PATCH 38/49] error handling, ghc version management --- .../src/Ide/Plugin/Rename.hs | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 8db96c6583..c0e99c94d8 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -40,8 +40,9 @@ descriptor pluginId = (defaultPluginDescriptor pluginId) { renameProvider :: PluginMethodHandler IdeState TextDocumentRename renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) = response $ do nfp <- safeGetNfp uri - oldName <- head <$> getNamesAtPos state pos nfp - refs <- liftIO $ runAction "Rename.references" state (refsAtName nfp oldName) + oldName <- (handleMaybe "error: could not find name at pos" . listToMaybe) =<< + getNamesAtPos state pos nfp + refs <- refsAtName state nfp oldName refFiles <- mapM safeGetNfp (nub [uri | Location uri _ <- refs]) let newNameStr = T.unpack newNameText newRdrName = mkRdrUnqual $ mkTcOcc newNameStr @@ -262,13 +263,13 @@ contextUpdater c@Context{ctxtBinders} i = const (pure c) ------------------------------------------------------------------------------- -- reference finding -refsAtName :: NormalizedFilePath -> Name -> Action [Location] -refsAtName nfp name = do - ShakeExtras{hiedb} <- getShakeExtras - fois <- HM.keys <$> getFilesOfInterestUntracked - Just ast <- useWithStale GetHieAst nfp - let Just fileRefs = getNameAstLocations name ast - Just mod = nameModule_maybe name + +refsAtName :: IdeState -> NormalizedFilePath -> Name -> ExceptT [Char] (LspT Config IO) [Location] +refsAtName state nfp name = do + ShakeExtras{hiedb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras + ast <- handleMaybeM "error: ast" $ liftIO $ runAction "" state $ useWithStale GetHieAst nfp + fileRefs <- handleMaybe "error: name references" $ getNameAstLocations name ast + mod <- handleMaybe "error: module name" $ nameModule_maybe name dbRefs <- liftIO $ mapMaybe rowToLoc <$> findReferences hiedb True @@ -302,10 +303,9 @@ locToSpan (Location uri (Range (Position l c) (Position l' c'))) = getNamesAtPos :: IdeState -> Position -> NormalizedFilePath -> ExceptT String (LspT Config IO) [Name] getNamesAtPos state pos nfp = do - (HAR{hieAst}, mapping) <- handleMaybeM "error: ast" $ - liftIO $ runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp - let oldName = getAstNamesAtPoint hieAst pos mapping - pure oldName + (HAR{hieAst}, mapping) <- handleMaybeM "error: ast" $ liftIO $ + runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp + pure $ getAstNamesAtPoint hieAst pos mapping subtractSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan subtractSrcSpans minuend (RealSrcSpan subtrahend) From b8dd9e2f2f5fec3c9a503d2d74ead2091844ef8a Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 13:05:12 +0100 Subject: [PATCH 39/49] ghc version compatibility management --- .github/workflows/test.yml | 4 ++++ haskell-language-server.cabal | 2 +- plugins/hls-rename-plugin/hls-rename-plugin.cabal | 1 - plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 2 +- stack-8.6.4.yaml | 1 - stack-8.6.5.yaml | 1 - 6 files changed, 6 insertions(+), 5 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 3a02d2763d..a976bbfb0c 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -208,3 +208,7 @@ jobs: - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}} name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" + + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}} + name: Test hls-call-rename-plugin test suite + run: cabal test hls-call-rename-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-rename-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --rename-options="-j1 --rerun" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 07fdf7a069..3f8f6095a4 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -457,7 +457,7 @@ test-suite func-test cpp-options: -Deval if flag(importLens) || flag(all-plugins) cpp-options: -DimportLens - if flag(rename) || flag(all-plugins) + if impl(ghc > 8.8) && (flag(rename) || flag(all-plugins)) cpp-options: -Drename if flag(retrie) || flag(all-plugins) cpp-options: -Dretrie diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 4bf1871f01..6bcf319915 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -35,7 +35,6 @@ library , hiedb , ghc-exactprint - if impl(ghc >= 8.8) build-depends: retrie >=1.0.0.0 default-language: Haskell2010 diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 5d03fe4133..7f4059ce77 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -371,7 +371,7 @@ callRetrie :: callRetrie = callRetrieWithTransformerAndUpdates defaultTransformer updateContext --- allows custom 'ContextUpdater' to be given to 'applyWithUpdates' +-- | allows custom 'ContextUpdater' to be given to 'applyWithUpdates' -- applies transformations to the spec callRetrieWithTransformerAndUpdates :: MatchResultTransformer -> diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 20601aea67..8129910681 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -16,7 +16,6 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - ./plugins/hls-tactics-plugin diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 0cce8fe49e..f012979944 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -15,7 +15,6 @@ packages: - ./plugins/hls-explicit-imports-plugin - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - ./plugins/hls-splice-plugin - ./plugins/hls-tactics-plugin From bd8692a0afe2d55c7cee12c66d484e8acaa0b485 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 13:23:40 +0100 Subject: [PATCH 40/49] fix: missing if in .cabal --- plugins/hls-rename-plugin/hls-rename-plugin.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 6bcf319915..4bf1871f01 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -35,6 +35,7 @@ library , hiedb , ghc-exactprint + if impl(ghc >= 8.8) build-depends: retrie >=1.0.0.0 default-language: Haskell2010 From 9c7f46bf5b77f124751972d7da19b69c5269d509 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 14:19:12 +0100 Subject: [PATCH 41/49] fix: typo in test.yaml --- .github/workflows/test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index a976bbfb0c..6585ec8448 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -210,5 +210,5 @@ jobs: run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}} - name: Test hls-call-rename-plugin test suite - run: cabal test hls-call-rename-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-rename-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --rename-options="-j1 --rerun" + name: Test hls-rename-plugin test suite + run: cabal test hls-rename-plugin --test-options="-j1 --rerun-update" || cabal test hls-rename-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --rename-options="-j1 --rerun" From 45b991fce8b6872625485a8b4801b9a2b28102d1 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 16:34:18 +0100 Subject: [PATCH 42/49] enable in ghc 9.0.1 --- cabal-ghc901.project | 2 +- stack-9.0.1.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 36b02a8034..aa84008ecb 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -15,7 +15,7 @@ packages: ./plugins/hls-explicit-imports-plugin ./plugins/hls-refine-imports-plugin ./plugins/hls-hlint-plugin - -- ./plugins/hls-rename-plugin + ./plugins/hls-rename-plugin ./plugins/hls-retrie-plugin ./plugins/hls-haddock-comments-plugin -- ./plugins/hls-splice-plugin diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index f0a5668051..6a9c143054 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -16,7 +16,7 @@ packages: - ./plugins/hls-explicit-imports-plugin # - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - # - ./plugins/hls-rename-plugin + - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin # - ./plugins/hls-splice-plugin # - ./plugins/hls-tactics-plugin From 21b8b25c029a346be3483e7eebec0e382f3f1fcf Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 17:05:28 +0100 Subject: [PATCH 43/49] remove GhcPlugins import --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index c0e99c94d8..bec81e425a 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -21,7 +21,6 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.AtPoint -import GhcPlugins hiding (getLoc, (<>)) import HieDb.Query import Ide.Plugin.Config import Ide.Plugin.Retrie hiding (descriptor) From 1c842bd57df753860a67a25a9d3c3d98c9b2a534 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 18:26:41 +0100 Subject: [PATCH 44/49] use HasSrcSpan from Ghc.Compact --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index bec81e425a..7ea73129b1 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -28,7 +28,7 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types hiding (_changes, _range) -import Retrie hiding (HsModule, getLoc) +import Retrie hiding (HasSrcSpan, HsModule, getLoc) import Retrie.SYB descriptor :: PluginId -> PluginDescriptor IdeState @@ -291,7 +291,7 @@ nfpToUri = filePathToUri . fromNormalizedFilePath safeGetNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath safeGetNfp uri = handleMaybe "error: uri" $ toNormalizedFilePath <$> uriToFilePath uri -isRef :: Retrie.HasSrcSpan a => [Location] -> a -> Bool +isRef :: HasSrcSpan a => [Location] -> a -> Bool isRef refs = (`elem` refs) . fromJust . srcSpanToLocation . getLoc locToSpan :: Location -> SrcSpan From 8a247cb20e21c72aa571eaed805226746552f4db Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 18:47:42 +0100 Subject: [PATCH 45/49] add CPP to use new HsModule for ghc >= 9.0.1 --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 7ea73129b1..e648725ad2 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} @@ -28,7 +29,8 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types hiding (_changes, _range) -import Retrie hiding (HasSrcSpan, HsModule, getLoc) +import Retrie hiding (HasSrcSpan, + HsModule, getLoc) import Retrie.SYB descriptor :: PluginId -> PluginDescriptor IdeState @@ -70,7 +72,11 @@ renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _pr getSrcEdits :: IdeState +#if MIN_VERSION_ghc(9,0,1) + -> (HsModule -> HsModule) +#else -> (HsModule GhcPs -> HsModule GhcPs) +#endif -> NormalizedFilePath -> ExceptT String (LspT Config IO) (List TextEdit) getSrcEdits state updateMod nfp = do From 203f78c9f6c9637da63c08d7cdcbef30693e7970 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 19:00:08 +0100 Subject: [PATCH 46/49] fix: use CPP for all occurence of HsModule --- .../src/Ide/Plugin/Rename.hs | 33 +++++++++++++++++-- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index e648725ad2..4ea0ce0417 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -89,11 +89,29 @@ getSrcEdits state updateMod nfp = do res = T.pack $ printA $ (fmap . fmap) updateMod annPs pure $ makeDiffTextEdit src res -updateExports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateExports :: + [Location] + -> RdrName +#if MIN_VERSION_ghc(9,0,1) + -> HsModule + -> HsModule +#else + -> HsModule GhcPs + -> HsModule GhcPs +#endif updateExports refs newRdrName ps@HsModule{hsmodExports} = ps {hsmodExports = (fmap . fmap) (map (fmap $ renameIE refs newRdrName)) hsmodExports} -updateImports :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateImports :: + [Location] + -> RdrName +#if MIN_VERSION_ghc(9,0,1) + -> HsModule + -> HsModule +#else + -> HsModule GhcPs + -> HsModule GhcPs +#endif updateImports refs newRdrName ps@HsModule{hsmodImports} = ps {hsmodImports = map (fmap renameImport) hsmodImports} where @@ -121,7 +139,16 @@ renameIE refs newRdrName IEThingWith{} renameIE _ _ export = export -- TODO: data constructor renames -updateLhsDecls :: [Location] -> RdrName -> HsModule GhcPs -> HsModule GhcPs +updateLhsDecls :: + [Location] + -> RdrName +#if MIN_VERSION_ghc(9,0,1) + -> HsModule + -> HsModule +#else + -> HsModule GhcPs + -> HsModule GhcPs +#endif updateLhsDecls refs newRdrName ps@HsModule{hsmodDecls} = ps {hsmodDecls = map (fmap renameLhsDecl) hsmodDecls} where From 8f9560320b4e47dd4c72d8b0a9a2fce4d3e4990f Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Mon, 16 Aug 2021 19:44:18 +0100 Subject: [PATCH 47/49] use OldRealSrcSpan --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 4ea0ce0417..60b170ce4c 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -340,7 +340,7 @@ getNamesAtPos state pos nfp = do pure $ getAstNamesAtPoint hieAst pos mapping subtractSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -subtractSrcSpans minuend (RealSrcSpan subtrahend) +subtractSrcSpans minuend (OldRealSrcSpan subtrahend) = mkSrcSpan startLoc endLoc where startLoc = mkSrcLoc (srcSpanFile subtrahend) (srcSpanStartLine subtrahend) (srcSpanEndCol subtrahend) From 33756cce045122777a090e96d0ee4bf5e61232e8 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 17 Aug 2021 03:57:16 +0100 Subject: [PATCH 48/49] code style --- .github/workflows/test.yml | 2 +- haskell-language-server.cabal | 2 +- .../hls-rename-plugin/hls-rename-plugin.cabal | 24 +++++------ .../src/Ide/Plugin/Rename.hs | 8 ++-- plugins/hls-rename-plugin/test/Main.hs | 41 +++++++++---------- .../hls-rename-plugin/test/testdata/hie.yaml | 22 +++++----- .../src/Ide/Plugin/Retrie.hs | 4 +- stack-8.10.3.yaml | 8 ++-- stack-8.10.4.yaml | 8 ++-- stack-8.10.5.yaml | 6 +-- stack-8.6.4.yaml | 8 ++-- stack.yaml | 8 ++-- 12 files changed, 67 insertions(+), 74 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 6585ec8448..dd8f575818 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -209,6 +209,6 @@ jobs: name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc >= '8.8.0'}} name: Test hls-rename-plugin test suite run: cabal test hls-rename-plugin --test-options="-j1 --rerun-update" || cabal test hls-rename-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --rename-options="-j1 --rerun" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3f8f6095a4..eb3811ede0 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -457,7 +457,7 @@ test-suite func-test cpp-options: -Deval if flag(importLens) || flag(all-plugins) cpp-options: -DimportLens - if impl(ghc > 8.8) && (flag(rename) || flag(all-plugins)) + if impl(ghc >= 8.8) && (flag(rename) || flag(all-plugins)) cpp-options: -Drename if flag(retrie) || flag(all-plugins) cpp-options: -Dretrie diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 4bf1871f01..857ea140e3 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -21,22 +21,20 @@ library hs-source-dirs: src build-depends: , aeson - , base >=4.12 && <5 - , lsp-types - , lsp - , hls-plugin-api ^>=1.2 - , ghcide >=1.4 && <1.5 - , transformers - , hls-retrie-plugin >= 1.0.1.1 - , text - , unordered-containers + , base >=4.12 && <5 , containers , ghc - , hiedb , ghc-exactprint - - if impl(ghc >= 8.8) - build-depends: retrie >=1.0.0.0 + , ghcide >=1.4 && <1.5 + , hiedb + , hls-plugin-api ^>=1.2 + , hls-retrie-plugin >= 1.0.1.1 + , lsp + , lsp-types + , retrie >=1.0.0.0 + , text + , transformers + , unordered-containers default-language: Haskell2010 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 60b170ce4c..eb18735052 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -138,7 +138,6 @@ renameIE refs newRdrName IEThingWith{} = error "not implemented explicit type import/export renames yet" renameIE _ _ export = export --- TODO: data constructor renames updateLhsDecls :: [Location] -> RdrName @@ -295,19 +294,18 @@ contextUpdater c@Context{ctxtBinders} i = const (pure c) ------------------------------------------------------------------------------- -- reference finding - refsAtName :: IdeState -> NormalizedFilePath -> Name -> ExceptT [Char] (LspT Config IO) [Location] refsAtName state nfp name = do ShakeExtras{hiedb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras ast <- handleMaybeM "error: ast" $ liftIO $ runAction "" state $ useWithStale GetHieAst nfp fileRefs <- handleMaybe "error: name references" $ getNameAstLocations name ast - mod <- handleMaybe "error: module name" $ nameModule_maybe name + let mod = nameModule_maybe name dbRefs <- liftIO $ mapMaybe rowToLoc <$> findReferences hiedb True (nameOccName name) - (Just $ moduleName mod) - (Just $ moduleUnitId mod) + (moduleName <$> mod) + (moduleUnitId <$> mod) [fromNormalizedFilePath nfp] pure $ nubOrd $ fileRefs ++ dbRefs diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 5a5d542ccf..d3f6e1cda3 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + module Main (main) where import qualified Ide.Plugin.Rename as Rename @@ -14,34 +15,33 @@ renamePlugin = Rename.descriptor "rename" tests :: TestTree tests = testGroup "rename" [ testGroup "Top-level renames" - [ goldenWithRename "function name" "FunctionName" $ \doc -> do + [ goldenWithRename "data constructor" "DataConstructor" $ \doc -> do + rename doc (Position 0 15) "Op" + , goldenWithRename "exported function" "ExportedFunction" $ \doc -> do + rename doc (Position 2 1) "quux" + , goldenWithRename "function name" "FunctionName" $ \doc -> do rename doc (Position 3 1) "baz" , goldenWithRename "GADT" "Gadt" $ \doc -> do rename doc (Position 6 37) "Expr" - , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do - rename doc (Position 3 8) "baz" - , goldenWithRename "exported function" "ExportedFunction" $ \doc -> do - rename doc (Position 2 1) "quux" , goldenWithRename "hidden function" "HiddenFunction" $ \doc -> do rename doc (Position 0 32) "quux" - , goldenWithRename "allign indentation" "Indentation" $ \doc -> do - rename doc (Position 0 2) "fooBarQuux" - , goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do - rename doc (Position 1 1) "baz" - , goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do - rename doc (Position 3 12) "baz" - , expectFailBecause "Bug: Test case giving different result to editor" $ - goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do - rename doc (Position 2 17) "BinaryTree" - , expectFailBecause "Not implemented yet" $ - goldenWithRename "data constructor" "DataConstructor" $ \doc -> do - rename doc (Position 0 13) "Apply" + , goldenWithRename "imported function" "ImportedFunction" $ \doc -> do + rename doc (Position 3 8) "baz" , goldenWithRename "import hiding" "ImportHiding" $ \doc -> do rename doc (Position 0 22) "hiddenFoo" + , goldenWithRename "allign indentation" "Indentation" $ \doc -> do + rename doc (Position 0 2) "fooBarQuux" , goldenWithRename "qualified as" "QualifiedAs" $ \doc -> do rename doc (Position 3 10) "baz" , goldenWithRename "qualified shadowing" "QualifiedShadowing" $ \doc -> do rename doc (Position 3 12) "foobar" + , goldenWithRename "qualified function" "QualifiedFunction" $ \doc -> do + rename doc (Position 3 12) "baz" + , goldenWithRename "shadowed name" "ShadowedName" $ \doc -> do + rename doc (Position 1 1) "baz" + , expectFailBecause "Bug: Test case giving different result to editor" $ + goldenWithRename "type constructor" "TypeConstructor" $ \doc -> do + rename doc (Position 2 17) "BinaryTree" ] , expectFailBecause "Only top-level renames are implemented" $ testGroup "non Top-level renames" @@ -55,11 +55,8 @@ tests = testGroup "rename" ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithRename title path act = - goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" $ \doc -> do - waitForProgressDone - waitForProgressDone - act doc +goldenWithRename title path = + goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-rename-plugin/test/testdata/hie.yaml b/plugins/hls-rename-plugin/test/testdata/hie.yaml index 166bde871f..535eb08fd1 100644 --- a/plugins/hls-rename-plugin/test/testdata/hie.yaml +++ b/plugins/hls-rename-plugin/test/testdata/hie.yaml @@ -1,20 +1,20 @@ cradle: direct: arguments: - - "FunctionName" - - "FunctionArgument" - - "ImportedFunction" + - "DataConstructor" - "ExportedFunction" + - "Foo" + - "FunctionArgument" + - "FunctionName" + - "Gadt" - "HiddenFunction" + - "ImportHiding" + - "ImportedFunction" + - "Indentation" + - "QualifiedAs" - "QualifiedFunction" + - "QualifiedShadowing" - "RecordField" - "ShadowedName" - - "TypeVariable" - "TypeConstructor" - - "DataConstructor" - - "Gadt" - - "Indentation" - - "Foo" - - "ImportHiding" - - "QualifiedAs" - - "QualifiedShadowing" + - "TypeVariable" diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 7f4059ce77..f67aa9f8a8 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -444,8 +444,8 @@ callRetrieWithTransformerAndUpdates transformer contextUpdater state session rew unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0 (originFixities, originParsedModule) <- reuseParsedModule origin - retrie <- do (\specs -> applyWithUpdate contextUpdater (map (setRewriteTransformer transformer) specs) - >> addImports annotatedImports) + retrie <- (\specs -> applyWithUpdate contextUpdater (map (setRewriteTransformer transformer) specs) + >> addImports annotatedImports) <$> parseRewriteSpecs (\_f -> return $ NoCPP originParsedModule) originFixities diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 85e2e6f021..59d9672173 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -72,11 +72,11 @@ extra-deps: configure-options: ghcide: - - --disable-library-for-ghci + - --disable-library-for-ghci haskell-language-server: - - --disable-library-for-ghci + - --disable-library-for-ghci heapsize: - - --disable-library-for-ghci + - --disable-library-for-ghci flags: haskell-language-server: @@ -92,6 +92,6 @@ flags: nix: - packages: [icu libcxx zlib] + packages: [ icu libcxx zlib ] concurrent-tests: false diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 2cfec00c21..a88d6bbfdb 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -74,11 +74,11 @@ extra-deps: configure-options: ghcide: - - --disable-library-for-ghci + - --disable-library-for-ghci haskell-language-server: - - --disable-library-for-ghci + - --disable-library-for-ghci heapsize: - - --disable-library-for-ghci + - --disable-library-for-ghci flags: haskell-language-server: @@ -94,6 +94,6 @@ flags: nix: - packages: [icu libcxx zlib] + packages: [ icu libcxx zlib ] concurrent-tests: false diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index 1e7c4a5fcd..168e2dcb7c 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -76,11 +76,11 @@ extra-deps: configure-options: ghcide: - - --disable-library-for-ghci + - --disable-library-for-ghci haskell-language-server: - - --disable-library-for-ghci + - --disable-library-for-ghci heapsize: - - --disable-library-for-ghci + - --disable-library-for-ghci flags: haskell-language-server: diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 8129910681..b37a0503b6 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -6,7 +6,7 @@ packages: - ./hie-compat - ./hls-graph - ./ghcide/ - # - ./shake-bench +# - ./shake-bench - ./hls-plugin-api - ./hls-test-utils - ./plugins/hls-call-hierarchy-plugin @@ -120,11 +120,11 @@ flags: configure-options: ghcide: - - --disable-library-for-ghci + - --disable-library-for-ghci haskell-language-server: - - --disable-library-for-ghci + - --disable-library-for-ghci heapsize: - - --disable-library-for-ghci + - --disable-library-for-ghci nix: packages: [icu libcxx zlib] diff --git a/stack.yaml b/stack.yaml index 6d704f1b34..bbc23834c7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,11 +67,11 @@ configure-options: $targets: - --enable-executable-dynamic ghcide: - - --disable-library-for-ghci + - --disable-library-for-ghci haskell-language-server: - - --disable-library-for-ghci + - --disable-library-for-ghci heapsize: - - --disable-library-for-ghci + - --disable-library-for-ghci flags: haskell-language-server: @@ -84,6 +84,6 @@ flags: hlint33: false nix: - packages: [icu libcxx zlib] + packages: [ icu libcxx zlib ] concurrent-tests: false From 5952677a95bf416151c6fb50171b26e56178b448 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Tue, 17 Aug 2021 06:35:18 +0100 Subject: [PATCH 49/49] update missing declaration error, disable data constructor test --- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs | 2 +- plugins/hls-rename-plugin/test/Main.hs | 14 ++++++++------ 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index eb18735052..9726357f57 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -54,7 +54,7 @@ renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _pr -- Rename left-hand sides (declarations) filesDeclEdits <- mapMToSnd (getSrcEdits state (updateLhsDecls refs newRdrName)) refFiles - declEdits@(originNfp, _) <- handleMaybe "error: could not find name declaration" $ + declEdits@(originNfp, _) <- handleMaybe "error: could not rename declaration" $ find (\(_, List xs) -> not $ null xs) filesDeclEdits -- Rename right-hand sides (using retrie) diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index d3f6e1cda3..1e3b3a3fc1 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -15,9 +15,7 @@ renamePlugin = Rename.descriptor "rename" tests :: TestTree tests = testGroup "rename" [ testGroup "Top-level renames" - [ goldenWithRename "data constructor" "DataConstructor" $ \doc -> do - rename doc (Position 0 15) "Op" - , goldenWithRename "exported function" "ExportedFunction" $ \doc -> do + [ goldenWithRename "exported function" "ExportedFunction" $ \doc -> do rename doc (Position 2 1) "quux" , goldenWithRename "function name" "FunctionName" $ \doc -> do rename doc (Position 3 1) "baz" @@ -45,7 +43,9 @@ tests = testGroup "rename" ] , expectFailBecause "Only top-level renames are implemented" $ testGroup "non Top-level renames" - [ goldenWithRename "function argument" "FunctionArgument" $ \doc -> do + [ goldenWithRename "data constructor" "DataConstructor" $ \doc -> do + rename doc (Position 0 15) "Op" + , goldenWithRename "function argument" "FunctionArgument" $ \doc -> do rename doc (Position 3 4) "y" , goldenWithRename "record field" "RecordField" $ \doc -> do rename doc (Position 6 9) "number" @@ -55,8 +55,10 @@ tests = testGroup "rename" ] goldenWithRename :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithRename title path = - goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" +goldenWithRename title path act = + goldenWithHaskellDoc renamePlugin title testDataDir path "expected" "hs" $ \doc -> do + waitForProgressDone + act doc testDataDir :: FilePath testDataDir = "test" "testdata"