Skip to content

Commit a91a2ee

Browse files
kozakkozak
committed
Strip prefixes added by DuplicateRecordFields to disambiguate record selectors from inlay hints
1 parent 30c58eb commit a91a2ee

File tree

5 files changed

+130
-7
lines changed

5 files changed

+130
-7
lines changed

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

Lines changed: 24 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Data.List (find, intersperse)
2626
import qualified Data.Map as Map
2727
import Data.Maybe (fromMaybe, isJust,
2828
mapMaybe, maybeToList)
29+
import Data.Monoid (First (..), getFirst)
2930
import Data.Text (Text)
3031
import qualified Data.Text as T
3132
import Data.Unique (hashUnique, newUnique)
@@ -48,6 +49,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping,
4849
toCurrentRange)
4950
import Development.IDE.Core.RuleTypes (TcModuleResult (..),
5051
TypeCheck (..))
52+
import Development.IDE.GHC.CoreFile (occNamePrefixes)
5153
import qualified Development.IDE.Core.Shake as Shake
5254
import Development.IDE.GHC.Compat (FieldLabel (flSelector),
5355
FieldOcc (FieldOcc),
@@ -238,7 +240,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen
238240
-- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False'
239241
nameEq = either (const False) ((==) name)
240242
in fmap fst $ find (nameEq . snd) filteredLocations
241-
valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
243+
valueWithLoc = [ (stripPrefix $ T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
242244
-- use `, ` to separate labels with definition location
243245
label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc
244246
pure $ InlayHint { _position = currentEnd -- at the end of dotdot
@@ -287,7 +289,7 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume
287289
, _data_ = Nothing
288290
}
289291

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

292294
mkTitle :: [Extension] -> Text
293295
mkTitle exts = "Expand record wildcard"
@@ -410,10 +412,10 @@ data RecordInfo
410412
deriving (Generic)
411413

412414
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)
415+
pretty (RecordInfoPat ss p) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable p)
416+
pretty (RecordInfoCon ss e) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable e)
415417
pretty (RecordInfoApp ss (RecordAppExpr _ _ fla))
416-
= pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
418+
= pretty (printFieldName ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
417419

418420
recordInfoToRange :: RecordInfo -> Range
419421
recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss
@@ -520,7 +522,7 @@ processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' }
520522

521523

522524
showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text
523-
showRecordPat names = fmap printOutputable . mapConPatDetail (\case
525+
showRecordPat names = fmap printFieldName . mapConPatDetail (\case
524526
RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)
525527
_ -> Nothing)
526528

@@ -561,7 +563,7 @@ showRecordApp (RecordAppExpr _ recConstr fla)
561563
= Just $ printOutputable recConstr <> " { "
562564
<> T.intercalate ", " (showFieldWithArg <$> fla)
563565
<> " }"
564-
where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg
566+
where showFieldWithArg (field, arg) = printFieldName field <> " = " <> printOutputable arg
565567

566568
collectRecords :: GenericQ [RecordInfo]
567569
collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)
@@ -641,3 +643,18 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds))
641643
mkRecInfo pat =
642644
[ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]]
643645
getRecPatterns _ = ([], False)
646+
647+
printFieldName :: Outputable a => a -> Text
648+
printFieldName = stripPrefix . printOutputable
649+
650+
{- When e.g. DuplicateRecordFields is enabled, compiler generates
651+
names like "$sel:accessor:One" and "$sel:accessor:Two" to
652+
disambiguate record selectors
653+
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
654+
-}
655+
-- See also:
656+
-- https://github.com/haskell/haskell-language-server/blob/master/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs#L811
657+
stripPrefix :: T.Text -> T.Text
658+
stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $
659+
getFirst $ foldMap (First . (`T.stripPrefix` name))
660+
occNamePrefixes

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

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

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 {..}

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

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

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

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)