Skip to content

Commit 0f6cd41

Browse files
OliverMadinemergify[bot]
OliverMadine
and
mergify[bot]
authored
Renaming of indirect references (RecordFieldPuns) (#3013)
* test: add tests for record puns * feat: rename indirect references refactor: remove "safe" from function names * test: ignore record field tests for ghc92 (#2915) * test: ignore record field tests for ghc90 (#2915) * fix: update record field test ignore message * expand comment about indirect reference renaming * fix: find all punned references * test: ignore record field pun test for ghc > 9 * docs: mention test in indirect pun explaination * link issue for ignored record field rename tests Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent ffefe76 commit 0f6cd41

File tree

7 files changed

+92
-35
lines changed

7 files changed

+92
-35
lines changed

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

Lines changed: 46 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@ import Data.Generics
2424
import Data.Hashable
2525
import Data.HashSet (HashSet)
2626
import qualified Data.HashSet as HS
27-
import Data.List.Extra
27+
import Data.List.Extra hiding (length)
2828
import qualified Data.Map as M
2929
import Data.Maybe
3030
import Data.Mod.Word
@@ -42,7 +42,6 @@ import Development.IDE.GHC.ExactPrint
4242
import Development.IDE.Spans.AtPoint
4343
import Development.IDE.Types.Location
4444
import HieDb.Query
45-
import Ide.Plugin.Config
4645
import Ide.Plugin.Properties
4746
import Ide.PluginUtils
4847
import Ide.Types
@@ -65,16 +64,28 @@ descriptor pluginId = (defaultPluginDescriptor pluginId)
6564
renameProvider :: PluginMethodHandler IdeState TextDocumentRename
6665
renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) =
6766
pluginResponse $ do
68-
nfp <- safeUriToNfp uri
69-
oldName <- getNameAtPos state nfp pos
70-
refLocs <- refsAtName state nfp oldName
67+
nfp <- handleUriToNfp uri
68+
directOldNames <- getNamesAtPos state nfp pos
69+
directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames
70+
71+
{- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have
72+
indirect references through punned names. To find the transitive closure, we do a pass of
73+
the direct references to find the references for any punned names.
74+
See the `IndirectPuns` test for an example. -}
75+
indirectOldNames <- concat . filter ((>1) . Prelude.length) <$>
76+
mapM (uncurry (getNamesAtPos state) . locToFilePos) directRefs
77+
let oldNames = indirectOldNames ++ directOldNames
78+
refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames
79+
80+
-- Validate rename
7181
crossModuleEnabled <- lift $ usePropertyLsp #crossModule pluginId properties
72-
unless crossModuleEnabled $ failWhenImportOrExport state nfp refLocs oldName
73-
when (isBuiltInSyntax oldName) $
74-
throwE ("Invalid rename of built-in syntax: \"" ++ showName oldName ++ "\"")
82+
unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames
83+
when (any isBuiltInSyntax oldNames) $ throwE "Invalid rename of built-in syntax"
84+
85+
-- Perform rename
7586
let newName = mkTcOcc $ T.unpack newNameText
76-
filesRefs = collectWith locToUri refLocs
77-
getFileEdit = flip $ getSrcEdit state . renameRefs newName
87+
filesRefs = collectWith locToUri refs
88+
getFileEdit = flip $ getSrcEdit state . replaceRefs newName
7889
fileEdits <- mapM (uncurry getFileEdit) filesRefs
7990
pure $ foldl' (<>) mempty fileEdits
8091

@@ -84,16 +95,16 @@ failWhenImportOrExport ::
8495
IdeState ->
8596
NormalizedFilePath ->
8697
HashSet Location ->
87-
Name ->
98+
[Name] ->
8899
ExceptT String m ()
89-
failWhenImportOrExport state nfp refLocs name = do
100+
failWhenImportOrExport state nfp refLocs names = do
90101
pm <- handleMaybeM ("No parsed module for: " ++ show nfp) $ liftIO $ runAction
91102
"Rename.GetParsedModule"
92103
state
93104
(use GetParsedModule nfp)
94105
let hsMod = unLoc $ pm_parsed_source pm
95106
case (unLoc <$> hsmodName hsMod, hsmodExports hsMod) of
96-
(mbModName, _) | not $ nameIsLocalOrFrom (replaceModName name mbModName) name
107+
(mbModName, _) | not $ any (\n -> nameIsLocalOrFrom (replaceModName n mbModName) n) names
97108
-> throwE "Renaming of an imported name is unsupported"
98109
(_, Just (L _ exports)) | any ((`HS.member` refLocs) . unsafeSrcSpanToLoc . getLoc) exports
99110
-> throwE "Renaming of an exported name is unsupported"
@@ -112,7 +123,7 @@ getSrcEdit ::
112123
ExceptT String m WorkspaceEdit
113124
getSrcEdit state updatePs uri = do
114125
ccs <- lift getClientCapabilities
115-
nfp <- safeUriToNfp uri
126+
nfp <- handleUriToNfp uri
116127
annAst <- handleMaybeM ("No parsed source for: " ++ show nfp) $ liftIO $ runAction
117128
"Rename.GetAnnotatedParsedSource"
118129
state
@@ -128,13 +139,13 @@ getSrcEdit state updatePs uri = do
128139
pure $ diffText ccs (uri, src) res IncludeDeletions
129140

130141
-- | Replace names at every given `Location` (in a given `ParsedSource`) with a given new name.
131-
renameRefs ::
142+
replaceRefs ::
132143
OccName ->
133144
HashSet Location ->
134145
ParsedSource ->
135146
ParsedSource
136147
#if MIN_VERSION_ghc(9,2,1)
137-
renameRefs newName refs = everywhere $
148+
replaceRefs newName refs = everywhere $
138149
-- there has to be a better way...
139150
mkT (replaceLoc @AnnListItem) `extT`
140151
-- replaceLoc @AnnList `extT` -- not needed
@@ -149,14 +160,13 @@ renameRefs newName refs = everywhere $
149160
| isRef (locA srcSpan) = L srcSpan $ replace oldRdrName
150161
replaceLoc lOldRdrName = lOldRdrName
151162
#else
152-
renameRefs newName refs = everywhere $ mkT replaceLoc
163+
replaceRefs newName refs = everywhere $ mkT replaceLoc
153164
where
154165
replaceLoc :: Located RdrName -> Located RdrName
155166
replaceLoc (L srcSpan oldRdrName)
156167
| isRef srcSpan = L srcSpan $ replace oldRdrName
157168
replaceLoc lOldRdrName = lOldRdrName
158169
#endif
159-
160170
replace :: RdrName -> RdrName
161171
replace (Qual modName _) = Qual modName newName
162172
replace _ = Unqual newName
@@ -173,10 +183,10 @@ refsAtName ::
173183
IdeState ->
174184
NormalizedFilePath ->
175185
Name ->
176-
ExceptT String m (HashSet Location)
186+
ExceptT String m [Location]
177187
refsAtName state nfp name = do
178188
ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras
179-
ast <- safeGetHieAst state nfp
189+
ast <- handleGetHieAst state nfp
180190
dbRefs <- case nameModule_maybe name of
181191
Nothing -> pure []
182192
Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb ->
@@ -188,32 +198,32 @@ refsAtName state nfp name = do
188198
(Just $ moduleUnit mod)
189199
[fromNormalizedFilePath nfp]
190200
)
191-
pure $ HS.fromList $ getNameLocs name ast ++ dbRefs
201+
pure $ nameLocs name ast ++ dbRefs
192202

193-
getNameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location]
194-
getNameLocs name (HAR _ _ rm _ _, pm) =
203+
nameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location]
204+
nameLocs name (HAR _ _ rm _ _, pm) =
195205
mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst)
196206
(concat $ M.lookup (Right name) rm)
197207

198208
---------------------------------------------------------------------------------------------------
199209
-- Util
200210

201-
getNameAtPos :: IdeState -> NormalizedFilePath -> Position -> ExceptT String (LspT Config IO) Name
202-
getNameAtPos state nfp pos = do
203-
(HAR{hieAst}, pm) <- safeGetHieAst state nfp
204-
handleMaybe ("No name at " ++ showPos pos) $ listToMaybe $ getNamesAtPoint hieAst pos pm
211+
getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT String m [Name]
212+
getNamesAtPos state nfp pos = do
213+
(HAR{hieAst}, pm) <- handleGetHieAst state nfp
214+
pure $ getNamesAtPoint hieAst pos pm
205215

206-
safeGetHieAst ::
216+
handleGetHieAst ::
207217
MonadIO m =>
208218
IdeState ->
209219
NormalizedFilePath ->
210220
ExceptT String m (HieAstResult, PositionMapping)
211-
safeGetHieAst state nfp = handleMaybeM
221+
handleGetHieAst state nfp = handleMaybeM
212222
("No AST for file: " ++ show nfp)
213223
(liftIO $ runAction "Rename.GetHieAst" state $ useWithStale GetHieAst nfp)
214224

215-
safeUriToNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath
216-
safeUriToNfp uri = handleMaybe
225+
handleUriToNfp :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath
226+
handleUriToNfp uri = handleMaybe
217227
("No filepath for uri: " ++ show uri)
218228
(toNormalizedFilePath <$> uriToFilePath uri)
219229

@@ -230,15 +240,17 @@ nfpToUri = filePathToUri . fromNormalizedFilePath
230240
showName :: Name -> String
231241
showName = occNameString . getOccName
232242

233-
showPos :: Position -> String
234-
showPos Position{_line, _character} = "line: " ++ show _line ++ " - character: " ++ show _character
235-
236243
unsafeSrcSpanToLoc :: SrcSpan -> Location
237244
unsafeSrcSpanToLoc srcSpan =
238245
case srcSpanToLocation srcSpan of
239246
Nothing -> error "Invalid conversion from UnhelpfulSpan to Location"
240247
Just location -> location
241248

249+
locToFilePos :: Location -> (NormalizedFilePath, Position)
250+
locToFilePos (Location uri (Range pos _)) = (nfp, pos)
251+
where
252+
Just nfp = (uriToNormalizedFilePath . toNormalizedUri) uri
253+
242254
replaceModName :: Name -> Maybe ModuleName -> Module
243255
replaceModName name mbModName =
244256
mkModule (moduleUnit $ nameModule name) (fromMaybe (mkModuleName "Main") mbModName)

‎plugins/hls-rename-plugin/test/Main.hs

Lines changed: 12 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,12 +15,19 @@ main = defaultTestRunner tests
1515
renamePlugin :: PluginDescriptor IdeState
1616
renamePlugin = Rename.descriptor "rename"
1717

18+
-- See https://github.com/wz1000/HieDb/issues/45
19+
recordConstructorIssue :: String
20+
recordConstructorIssue = "HIE references for record fields incorrect with GHC versions >= 9"
21+
1822
tests :: TestTree
1923
tests = testGroup "Rename"
2024
[ goldenWithRename "Data constructor" "DataConstructor" $ \doc ->
2125
rename doc (Position 0 15) "Op"
2226
, goldenWithRename "Exported function" "ExportedFunction" $ \doc ->
2327
rename doc (Position 2 1) "quux"
28+
, ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $
29+
goldenWithRename "Field Puns" "FieldPuns" $ \doc ->
30+
rename doc (Position 7 13) "bleh"
2431
, goldenWithRename "Function argument" "FunctionArgument" $ \doc ->
2532
rename doc (Position 3 4) "y"
2633
, goldenWithRename "Function name" "FunctionName" $ \doc ->
@@ -33,6 +40,9 @@ tests = testGroup "Rename"
3340
rename doc (Position 3 8) "baz"
3441
, goldenWithRename "Import hiding" "ImportHiding" $ \doc ->
3542
rename doc (Position 0 22) "hiddenFoo"
43+
, ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $
44+
goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc ->
45+
rename doc (Position 4 23) "blah"
3646
, goldenWithRename "Let expression" "LetExpression" $ \doc ->
3747
rename doc (Position 5 11) "foobar"
3848
, goldenWithRename "Qualified as" "QualifiedAs" $ \doc ->
@@ -43,7 +53,8 @@ tests = testGroup "Rename"
4353
rename doc (Position 3 12) "baz"
4454
, goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc ->
4555
rename doc (Position 0 2) "fooBarQuux"
46-
, goldenWithRename "Record field" "RecordField" $ \doc ->
56+
, ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $
57+
goldenWithRename "Record field" "RecordField" $ \doc ->
4758
rename doc (Position 6 9) "number"
4859
, goldenWithRename "Shadowed name" "ShadowedName" $ \doc ->
4960
rename doc (Position 1 1) "baz"

‎plugins/hls-rename-plugin/test/testdata/FieldPuns.expected.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
3+
module FieldPun () where
4+
5+
newtype Foo = Foo { bleh :: Int }
6+
7+
unFoo :: Foo -> Int
8+
unFoo Foo{bleh} = bleh

‎plugins/hls-rename-plugin/test/testdata/FieldPuns.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
3+
module FieldPun () where
4+
5+
newtype Foo = Foo { field :: Int }
6+
7+
unFoo :: Foo -> Int
8+
unFoo Foo{field} = field

‎plugins/hls-rename-plugin/test/testdata/IndirectPuns.expected.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
3+
module IndirectPuns () where
4+
5+
newtype Foo = Foo { blah :: Int }
6+
7+
unFoo :: Foo -> Int
8+
unFoo Foo{blah} = blah

‎plugins/hls-rename-plugin/test/testdata/IndirectPuns.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
3+
module IndirectPuns () where
4+
5+
newtype Foo = Foo { field :: Int }
6+
7+
unFoo :: Foo -> Int
8+
unFoo Foo{field} = field

‎plugins/hls-rename-plugin/test/testdata/hie.yaml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,13 +3,15 @@ cradle:
33
arguments:
44
- "DataConstructor"
55
- "ExportedFunction"
6+
- "FieldPuns"
67
- "Foo"
78
- "FunctionArgument"
89
- "FunctionName"
910
- "Gadt"
1011
- "HiddenFunction"
1112
- "ImportHiding"
1213
- "ImportedFunction"
14+
- "IndirectPuns"
1315
- "LetExpression"
1416
- "QualifiedAs"
1517
- "QualifiedFunction"

0 commit comments

Comments
 (0)