Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 63e03b9

Browse files
authored
Strip prefixes added by DuplicateRecordFields (#4593)
* Strip prefixes added by DuplicateRecordFields to disambiguate record selectors from inlay hints * Fix style * Extract stripPrefixes to a common utility, convert comment to haddoc * Move to GHC Util
1 parent 30c58eb commit 63e03b9

File tree

8 files changed

+176
-65
lines changed

8 files changed

+176
-65
lines changed

‎ghcide/src/Development/IDE/GHC/CoreFile.hs‎

Lines changed: 1 addition & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ module Development.IDE.GHC.CoreFile
1010
, readBinCoreFile
1111
, writeBinCoreFile
1212
, getImplicitBinds
13-
, occNamePrefixes) where
13+
) where
1414

1515
import Control.Monad
1616
import Control.Monad.IO.Class
@@ -223,44 +223,3 @@ tc_iface_bindings (TopIfaceRec vs) = do
223223
vs' <- traverse (\(v, e) -> (v,) <$> tcIfaceExpr e) vs
224224
pure $ Rec vs'
225225

226-
-- | Prefixes that can occur in a GHC OccName
227-
occNamePrefixes :: [T.Text]
228-
occNamePrefixes =
229-
[
230-
-- long ones
231-
"$con2tag_"
232-
, "$tag2con_"
233-
, "$maxtag_"
234-
235-
-- four chars
236-
, "$sel:"
237-
, "$tc'"
238-
239-
-- three chars
240-
, "$dm"
241-
, "$co"
242-
, "$tc"
243-
, "$cp"
244-
, "$fx"
245-
246-
-- two chars
247-
, "$W"
248-
, "$w"
249-
, "$m"
250-
, "$b"
251-
, "$c"
252-
, "$d"
253-
, "$i"
254-
, "$s"
255-
, "$f"
256-
, "$r"
257-
, "C:"
258-
, "N:"
259-
, "D:"
260-
, "$p"
261-
, "$L"
262-
, "$f"
263-
, "$t"
264-
, "$c"
265-
, "$m"
266-
]

‎ghcide/src/Development/IDE/GHC/Util.hs‎

Lines changed: 55 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,8 @@ module Development.IDE.GHC.Util(
2727
dontWriteHieFiles,
2828
disableWarningsAsErrors,
2929
printOutputable,
30-
getExtensions
30+
getExtensions,
31+
stripOccNamePrefix,
3132
) where
3233

3334
import Control.Concurrent
@@ -62,6 +63,7 @@ import GHC.IO.Handle.Types
6263
import Ide.PluginUtils (unescape)
6364
import System.FilePath
6465

66+
import Data.Monoid (First (..))
6567
import GHC.Data.EnumSet
6668
import GHC.Data.FastString
6769
import GHC.Data.StringBuffer
@@ -271,3 +273,55 @@ printOutputable =
271273

272274
getExtensions :: ParsedModule -> [Extension]
273275
getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary
276+
277+
-- | When e.g. DuplicateRecordFields is enabled, compiler generates
278+
-- names like "$sel:accessor:One" and "$sel:accessor:Two" to
279+
-- disambiguate record selectors
280+
-- https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
281+
stripOccNamePrefix :: T.Text -> T.Text
282+
stripOccNamePrefix name = T.takeWhile (/=':') $ fromMaybe name $
283+
getFirst $ foldMap (First . (`T.stripPrefix` name))
284+
occNamePrefixes
285+
286+
-- | Prefixes that can occur in a GHC OccName
287+
occNamePrefixes :: [T.Text]
288+
occNamePrefixes =
289+
[
290+
-- long ones
291+
"$con2tag_"
292+
, "$tag2con_"
293+
, "$maxtag_"
294+
295+
-- four chars
296+
, "$sel:"
297+
, "$tc'"
298+
299+
-- three chars
300+
, "$dm"
301+
, "$co"
302+
, "$tc"
303+
, "$cp"
304+
, "$fx"
305+
306+
-- two chars
307+
, "$W"
308+
, "$w"
309+
, "$m"
310+
, "$b"
311+
, "$c"
312+
, "$d"
313+
, "$i"
314+
, "$s"
315+
, "$f"
316+
, "$r"
317+
, "C:"
318+
, "N:"
319+
, "D:"
320+
, "$p"
321+
, "$L"
322+
, "$f"
323+
, "$t"
324+
, "$c"
325+
, "$m"
326+
]
327+

‎ghcide/src/Development/IDE/Plugin/Completions/Logic.hs‎

Lines changed: 1 addition & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -37,14 +37,12 @@ import Data.Aeson (ToJSON (toJSON))
3737
import Data.Function (on)
3838

3939
import qualified Data.HashSet as HashSet
40-
import Data.Monoid (First (..))
4140
import Data.Ord (Down (Down))
4241
import qualified Data.Set as Set
4342
import Development.IDE.Core.PositionMapping
4443
import Development.IDE.GHC.Compat hiding (isQual, ppr)
4544
import qualified Development.IDE.GHC.Compat as GHC
4645
import Development.IDE.GHC.Compat.Util
47-
import Development.IDE.GHC.CoreFile (occNamePrefixes)
4846
import Development.IDE.GHC.Error
4947
import Development.IDE.GHC.Util
5048
import Development.IDE.Plugin.Completions.Types
@@ -261,7 +259,7 @@ mkNameCompItem doc thingParent origName provenance isInfix !imp mod = CI {..}
261259
compKind = occNameToComKind origName
262260
isTypeCompl = isTcOcc origName
263261
typeText = Nothing
264-
label = stripPrefix $ printOutputable origName
262+
label = stripOccNamePrefix $ printOutputable origName
265263
insertText = case isInfix of
266264
Nothing -> label
267265
Just LeftSide -> label <> "`"
@@ -801,17 +799,6 @@ openingBacktick line prefixModule prefixText Position { _character=(fromIntegral
801799

802800
-- ---------------------------------------------------------------------
803801

804-
-- | Under certain circumstance GHC generates some extra stuff that we
805-
-- don't want in the autocompleted symbols
806-
{- When e.g. DuplicateRecordFields is enabled, compiler generates
807-
names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
808-
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
809-
-}
810-
-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
811-
stripPrefix :: T.Text -> T.Text
812-
stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $
813-
getFirst $ foldMap (First . (`T.stripPrefix` name)) occNamePrefixes
814-
815802
mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem
816803
mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r
817804
where

‎plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs‎

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,8 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns
8282
pattern RealSrcSpan,
8383
plusUFM_C, unitUFM)
8484
import Development.IDE.GHC.Util (getExtensions,
85-
printOutputable)
85+
printOutputable,
86+
stripOccNamePrefix)
8687
import Development.IDE.Graph (RuleResult)
8788
import Development.IDE.Graph.Classes (Hashable, NFData)
8889
import Development.IDE.Spans.Pragmas (NextPragmaInfo (..),
@@ -238,7 +239,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen
238239
-- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False'
239240
nameEq = either (const False) ((==) name)
240241
in fmap fst $ find (nameEq . snd) filteredLocations
241-
valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
242+
valueWithLoc = [ (stripOccNamePrefix $T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
242243
-- use `, ` to separate labels with definition location
243244
label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc
244245
pure $ InlayHint { _position = currentEnd -- at the end of dotdot
@@ -287,7 +288,7 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume
287288
, _data_ = Nothing
288289
}
289290

290-
mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing
291+
mkInlayHintLabelPart name loc = InlayHintLabelPart (printFieldName (pprNameUnqualified name) <> "=") Nothing loc Nothing
291292

292293
mkTitle :: [Extension] -> Text
293294
mkTitle exts = "Expand record wildcard"
@@ -410,10 +411,10 @@ data RecordInfo
410411
deriving (Generic)
411412

412413
instance Pretty RecordInfo where
413-
pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p)
414-
pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e)
414+
pretty (RecordInfoPat ss p) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable p)
415+
pretty (RecordInfoCon ss e) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable e)
415416
pretty (RecordInfoApp ss (RecordAppExpr _ _ fla))
416-
= pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
417+
= pretty (printFieldName ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
417418

418419
recordInfoToRange :: RecordInfo -> Range
419420
recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss
@@ -520,7 +521,7 @@ processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' }
520521

521522

522523
showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text
523-
showRecordPat names = fmap printOutputable . mapConPatDetail (\case
524+
showRecordPat names = fmap printFieldName . mapConPatDetail (\case
524525
RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)
525526
_ -> Nothing)
526527

@@ -561,7 +562,7 @@ showRecordApp (RecordAppExpr _ recConstr fla)
561562
= Just $ printOutputable recConstr <> " { "
562563
<> T.intercalate ", " (showFieldWithArg <$> fla)
563564
<> " }"
564-
where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg
565+
where showFieldWithArg (field, arg) = printFieldName field <> " = " <> printOutputable arg
565566

566567
collectRecords :: GenericQ [RecordInfo]
567568
collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)
@@ -641,3 +642,7 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds))
641642
mkRecInfo pat =
642643
[ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]]
643644
getRecPatterns _ = ([], False)
645+
646+
printFieldName :: Outputable a => a -> Text
647+
printFieldName = stripOccNamePrefix . printOutputable
648+

‎plugins/hls-explicit-record-fields-plugin/test/Main.hs‎

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,24 @@ test = testGroup "explicit-fields"
5757
, _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"
5858
, _paddingLeft = Just True
5959
}]
60+
, mkInlayHintsTest "ConstructionDuplicateRecordFields" Nothing 16 $ \ih -> do
61+
let mkLabelPart' = mkLabelPartOffsetLength "ConstructionDuplicateRecordFields"
62+
foo <- mkLabelPart' 13 6 "foo"
63+
bar <- mkLabelPart' 14 6 "bar"
64+
baz <- mkLabelPart' 15 6 "baz"
65+
(@?=) ih
66+
[defInlayHint { _position = Position 16 14
67+
, _label = InR [ foo, commaPart
68+
, bar, commaPart
69+
, baz
70+
]
71+
, _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15
72+
, mkPragmaTextEdit 3 -- Not 2 of the DuplicateRecordFields pragma
73+
]
74+
, _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"
75+
, _paddingLeft = Just True
76+
}]
77+
6078
, mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do
6179
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction"
6280
foo <- mkLabelPart' 5 4 "foo="
@@ -82,6 +100,31 @@ test = testGroup "explicit-fields"
82100
, _paddingLeft = Nothing
83101
}
84102
]
103+
, mkInlayHintsTest "PositionalConstructionDuplicateRecordFields" Nothing 15 $ \ih -> do
104+
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstructionDuplicateRecordFields"
105+
foo <- mkLabelPart' 5 4 "foo="
106+
bar <- mkLabelPart' 6 4 "bar="
107+
baz <- mkLabelPart' 7 4 "baz="
108+
(@?=) ih
109+
[ defInlayHint { _position = Position 15 11
110+
, _label = InR [ foo ]
111+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
112+
, _tooltip = Just $ InL "Expand positional record"
113+
, _paddingLeft = Nothing
114+
}
115+
, defInlayHint { _position = Position 15 13
116+
, _label = InR [ bar ]
117+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
118+
, _tooltip = Just $ InL "Expand positional record"
119+
, _paddingLeft = Nothing
120+
}
121+
, defInlayHint { _position = Position 15 15
122+
, _label = InR [ baz ]
123+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
124+
, _tooltip = Just $ InL "Expand positional record"
125+
, _paddingLeft = Nothing
126+
}
127+
]
85128
, mkInlayHintsTest "HsExpanded1" Nothing 17 $ \ih -> do
86129
let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded1"
87130
foo <- mkLabelPart' 11 4 "foo"
@@ -102,6 +145,16 @@ test = testGroup "explicit-fields"
102145
, _tooltip = Just $ InL "Expand positional record"
103146
, _paddingLeft = Nothing
104147
}]
148+
, mkInlayHintsTest "HsExpanded1DuplicateRecordFields" (Just " (positional)") 13 $ \ih -> do
149+
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1DuplicateRecordFields"
150+
foo <- mkLabelPart' 11 4 "foo="
151+
(@?=) ih
152+
[defInlayHint { _position = Position 13 21
153+
, _label = InR [ foo ]
154+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ]
155+
, _tooltip = Just $ InL "Expand positional record"
156+
, _paddingLeft = Nothing
157+
}]
105158
, mkInlayHintsTest "HsExpanded2" Nothing 23 $ \ih -> do
106159
let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded2"
107160
bar <- mkLabelPart' 14 4 "bar"
Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
{-# LANGUAGE Haskell2010 #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE DuplicateRecordFields #-}
4+
module Construction where
5+
6+
data MyRec = MyRec
7+
{ foo :: Int
8+
, bar :: Int
9+
, baz :: Char
10+
}
11+
12+
convertMe :: () -> MyRec
13+
convertMe _ =
14+
let foo = 3
15+
bar = 5
16+
baz = 'a'
17+
in MyRec {..}
Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
{-# LANGUAGE RebindableSyntax #-}
3+
{-# LANGUAGE NamedFieldPuns #-}
4+
{-# LANGUAGE DuplicateRecordFields #-}
5+
module HsExpanded1DuplicateRecordFields where
6+
import Prelude
7+
8+
ifThenElse :: Int -> Int -> Int -> Int
9+
ifThenElse x y z = x + y + z
10+
11+
data MyRec = MyRec
12+
{ foo :: Int }
13+
14+
myRecExample = MyRec 5
15+
16+
convertMe :: Int
17+
convertMe =
18+
if (let MyRec {..} = myRecExample
19+
in foo) then 1 else 2
Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
{-# LANGUAGE Haskell2010 #-}
2+
{-# LANGUAGE DuplicateRecordFields #-}
3+
module PositionalConstruction where
4+
5+
data MyRec = MyRec
6+
{ foo :: Int
7+
, bar :: Int
8+
, baz :: Char
9+
}
10+
11+
convertMe :: () -> MyRec
12+
convertMe _ =
13+
let a = 3
14+
b = 5
15+
c = 'a'
16+
in MyRec a b c
17+

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /