Skip to content

Commit e83f3bc

Browse files
kozakkozak
committed
Strip prefixes added by DuplicateRecordFields to disambiguate record selectors from inlay hints
1 parent e00b5dd commit e83f3bc

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),
@@ -226,7 +228,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen
226228
-- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False'
227229
nameEq = either (const False) ((==) name)
228230
in fmap fst $ find (nameEq . snd) filteredLocations
229-
valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
231+
valueWithLoc = [ (stripPrefix $ T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
230232
-- use `, ` to separate labels with definition location
231233
label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc
232234
pure $ InlayHint { _position = currentEnd -- at the end of dotdot
@@ -275,7 +277,7 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume
275277
, _data_ = Nothing
276278
}
277279

278-
mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing
280+
mkInlayHintLabelPart name loc = InlayHintLabelPart (printFieldName (pprNameUnqualified name) <> "=") Nothing loc Nothing
279281

280282
mkTitle :: [Extension] -> Text
281283
mkTitle exts = "Expand record wildcard"
@@ -389,10 +391,10 @@ data RecordInfo
389391
deriving (Generic)
390392

391393
instance Pretty RecordInfo where
392-
pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p)
393-
pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e)
394+
pretty (RecordInfoPat ss p) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable p)
395+
pretty (RecordInfoCon ss e) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable e)
394396
pretty (RecordInfoApp ss (RecordAppExpr _ fla))
395-
= pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
397+
= pretty (printFieldName ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
396398

397399
recordInfoToRange :: RecordInfo -> Range
398400
recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss
@@ -499,7 +501,7 @@ processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' }
499501

500502

501503
showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text
502-
showRecordPat names = fmap printOutputable . mapConPatDetail (\case
504+
showRecordPat names = fmap printFieldName . mapConPatDetail (\case
503505
RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)
504506
_ -> Nothing)
505507

@@ -540,7 +542,7 @@ showRecordApp (RecordAppExpr recConstr fla)
540542
= Just $ printOutputable recConstr <> " { "
541543
<> T.intercalate ", " (showFieldWithArg <$> fla)
542544
<> " }"
543-
where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg
545+
where showFieldWithArg (field, arg) = printFieldName field <> " = " <> printOutputable arg
544546

545547
collectRecords :: GenericQ [RecordInfo]
546548
collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)
@@ -614,3 +616,18 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds))
614616
mkRecInfo pat =
615617
[ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]]
616618
getRecPatterns _ = ([], False)
619+
620+
printFieldName :: Outputable a => a -> Text
621+
printFieldName = stripPrefix . printOutputable
622+
623+
{- When e.g. DuplicateRecordFields is enabled, compiler generates
624+
names like "$sel:accessor:One" and "$sel:accessor:Two" to
625+
disambiguate record selectors
626+
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
627+
-}
628+
-- See also:
629+
-- https://github.com/haskell/haskell-language-server/blob/master/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs#L811
630+
stripPrefix :: T.Text -> T.Text
631+
stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $
632+
getFirst $ foldMap (First . (`T.stripPrefix` name))
633+
occNamePrefixes

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

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,24 @@ test = testGroup "explicit-fields"
5656
, _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"
5757
, _paddingLeft = Just True
5858
}]
59+
, mkInlayHintsTest "ConstructionDuplicateRecordFields" Nothing 16 $ \ih -> do
60+
let mkLabelPart' = mkLabelPartOffsetLength "ConstructionDuplicateRecordFields"
61+
foo <- mkLabelPart' 13 6 "foo"
62+
bar <- mkLabelPart' 14 6 "bar"
63+
baz <- mkLabelPart' 15 6 "baz"
64+
(@?=) ih
65+
[defInlayHint { _position = Position 16 14
66+
, _label = InR [ foo, commaPart
67+
, bar, commaPart
68+
, baz
69+
]
70+
, _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15
71+
, mkPragmaTextEdit 3 -- Not 2 of the DuplicateRecordFields pragma
72+
]
73+
, _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"
74+
, _paddingLeft = Just True
75+
}]
76+
5977
, mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do
6078
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction"
6179
foo <- mkLabelPart' 5 4 "foo="
@@ -81,6 +99,31 @@ test = testGroup "explicit-fields"
8199
, _paddingLeft = Nothing
82100
}
83101
]
102+
, mkInlayHintsTest "PositionalConstructionDuplicateRecordFields" Nothing 15 $ \ih -> do
103+
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstructionDuplicateRecordFields"
104+
foo <- mkLabelPart' 5 4 "foo="
105+
bar <- mkLabelPart' 6 4 "bar="
106+
baz <- mkLabelPart' 7 4 "baz="
107+
(@?=) ih
108+
[ defInlayHint { _position = Position 15 11
109+
, _label = InR [ foo ]
110+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
111+
, _tooltip = Just $ InL "Expand positional record"
112+
, _paddingLeft = Nothing
113+
}
114+
, defInlayHint { _position = Position 15 13
115+
, _label = InR [ bar ]
116+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
117+
, _tooltip = Just $ InL "Expand positional record"
118+
, _paddingLeft = Nothing
119+
}
120+
, defInlayHint { _position = Position 15 15
121+
, _label = InR [ baz ]
122+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
123+
, _tooltip = Just $ InL "Expand positional record"
124+
, _paddingLeft = Nothing
125+
}
126+
]
84127
, mkInlayHintsTest "HsExpanded1" Nothing 17 $ \ih -> do
85128
let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded1"
86129
foo <- mkLabelPart' 11 4 "foo"
@@ -101,6 +144,16 @@ test = testGroup "explicit-fields"
101144
, _tooltip = Just $ InL "Expand positional record"
102145
, _paddingLeft = Nothing
103146
}]
147+
, mkInlayHintsTest "HsExpanded1DuplicateRecordFields" (Just " (positional)") 13 $ \ih -> do
148+
let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1DuplicateRecordFields"
149+
foo <- mkLabelPart' 11 4 "foo="
150+
(@?=) ih
151+
[defInlayHint { _position = Position 13 21
152+
, _label = InR [ foo ]
153+
, _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ]
154+
, _tooltip = Just $ InL "Expand positional record"
155+
, _paddingLeft = Nothing
156+
}]
104157
, mkInlayHintsTest "HsExpanded2" Nothing 23 $ \ih -> do
105158
let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded2"
106159
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)