Strip prefixes added by DuplicateRecordFields

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

@@ -26,6 +26,7 @@ import           Data.List                            (find, intersperse)
 import qualified Data.Map                             as Map
 import           Data.Maybe                           (fromMaybe, isJust,
                                                        mapMaybe, maybeToList)
+import           Data.Monoid                          (First (..), getFirst)
 import           Data.Text                            (Text)
 import qualified Data.Text                            as T
 import           Data.Unique                          (hashUnique, newUnique)
@@ -81,6 +82,7 @@ import           Development.IDE.GHC.Compat.Core      (Extension (NamedFieldPuns
                                                        mapConPatDetail, mapLoc,
                                                        pattern RealSrcSpan,
                                                        plusUFM_C, unitUFM)
+import           Development.IDE.GHC.CoreFile         (occNamePrefixes)
 import           Development.IDE.GHC.Util             (getExtensions,
                                                        printOutputable)
 import           Development.IDE.Graph                (RuleResult)
@@ -226,7 +228,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen
                    -- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False'
                    nameEq = either (const False) ((==) name)
                 in fmap fst $ find (nameEq . snd) filteredLocations
-             valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
+             valueWithLoc = [ (stripPrefix $ T.pack $ printName name, findLocation name defnLocs') | name <- names' ]
              -- use `, ` to separate labels with definition location
              label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc
          pure $ InlayHint { _position = currentEnd -- at the end of dotdot
@@ -275,7 +277,7 @@ inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocume
                         , _data_ = Nothing
                         }
 
-     mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing
+     mkInlayHintLabelPart name loc = InlayHintLabelPart (printFieldName (pprNameUnqualified name) <> "=") Nothing loc Nothing
 
 mkTitle :: [Extension] -> Text
 mkTitle exts = "Expand record wildcard"
@@ -389,10 +391,10 @@ data RecordInfo
   deriving (Generic)
 
 instance Pretty RecordInfo where
-  pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p)
-  pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e)
+  pretty (RecordInfoPat ss p) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable p)
+  pretty (RecordInfoCon ss e) = pretty (printFieldName ss) <> ":" <+> pretty (printOutputable e)
   pretty (RecordInfoApp ss (RecordAppExpr _ fla))
-    = pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
+    = pretty (printFieldName ss) <> ":" <+> hsep (map (pretty . printOutputable) fla)
 
 recordInfoToRange :: RecordInfo -> Range
 recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss
@@ -499,7 +501,7 @@ processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' }
 
 
 showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text
-showRecordPat names = fmap printOutputable . mapConPatDetail (\case
+showRecordPat names = fmap printFieldName . mapConPatDetail (\case
   RecCon flds -> Just $ RecCon (preprocessRecordPat names flds)
   _           -> Nothing)
 
@@ -540,7 +542,7 @@ showRecordApp (RecordAppExpr recConstr fla)
   = Just $ printOutputable recConstr <>  " { "
          <> T.intercalate ", " (showFieldWithArg <$> fla)
          <> " }"
-  where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg
+  where showFieldWithArg (field, arg) = printFieldName field <> " = " <> printOutputable arg
 
 collectRecords :: GenericQ [RecordInfo]
 collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons)
@@ -614,3 +616,18 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds))
     mkRecInfo pat =
       [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]]
 getRecPatterns _ = ([], False)
+
+printFieldName :: Outputable a => a -> Text
+printFieldName = stripPrefix . printOutputable
+
+{- When e.g. DuplicateRecordFields is enabled, compiler generates
+    names like "$sel:accessor:One" and "$sel:accessor:Two" to
+    disambiguate record selectors
+    https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
+-}
+-- See also:
+-- https://github.com/haskell/haskell-language-server/blob/master/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs#L811
+stripPrefix :: T.Text -> T.Text
+stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $
+    getFirst $ foldMap (First . (`T.stripPrefix` name))
+    occNamePrefixes

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

@@ -56,6 +56,24 @@ test = testGroup "explicit-fields"
                         , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"
                         , _paddingLeft = Just True
                         }]
+    , mkInlayHintsTest "ConstructionDuplicateRecordFields" Nothing 16 $ \ih -> do
+        let mkLabelPart' = mkLabelPartOffsetLength "ConstructionDuplicateRecordFields"
+        foo <- mkLabelPart' 13 6 "foo"
+        bar <- mkLabelPart' 14 6 "bar"
+        baz <- mkLabelPart' 15 6 "baz"
+        (@?=) ih
+          [defInlayHint { _position = Position 16 14
+                        , _label = InR [ foo, commaPart
+                                       , bar, commaPart
+                                       , baz
+                                       ]
+                        , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15
+                                            , mkPragmaTextEdit 3 -- Not 2 of the DuplicateRecordFields pragma
+                                            ]
+                        , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)"
+                        , _paddingLeft = Just True
+                        }]
+
     , mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do
         let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction"
         foo <- mkLabelPart' 5 4 "foo="
@@ -81,6 +99,31 @@ test = testGroup "explicit-fields"
                          , _paddingLeft = Nothing
                          }
           ]
+    , mkInlayHintsTest "PositionalConstructionDuplicateRecordFields" Nothing 15 $ \ih -> do
+        let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstructionDuplicateRecordFields"
+        foo <- mkLabelPart' 5 4 "foo="
+        bar <- mkLabelPart' 6 4 "bar="
+        baz <- mkLabelPart' 7 4 "baz="
+        (@?=) ih
+          [ defInlayHint { _position = Position 15 11
+                         , _label = InR [ foo ]
+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
+                         , _tooltip = Just $ InL "Expand positional record"
+                         , _paddingLeft = Nothing
+                         }
+          , defInlayHint { _position = Position 15 13
+                         , _label = InR [ bar ]
+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
+                         , _tooltip = Just $ InL "Expand positional record"
+                         , _paddingLeft = Nothing
+                         }
+          , defInlayHint { _position = Position 15 15
+                         , _label = InR [ baz ]
+                         , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ]
+                         , _tooltip = Just $ InL "Expand positional record"
+                         , _paddingLeft = Nothing
+                         }
+          ]
     , mkInlayHintsTest "HsExpanded1" Nothing 17 $ \ih -> do
         let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded1"
         foo <- mkLabelPart' 11 4 "foo"
@@ -101,6 +144,16 @@ test = testGroup "explicit-fields"
                         , _tooltip = Just $ InL "Expand positional record"
                         , _paddingLeft = Nothing
                         }]
+    , mkInlayHintsTest "HsExpanded1DuplicateRecordFields" (Just " (positional)") 13 $ \ih -> do
+        let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1DuplicateRecordFields"
+        foo <- mkLabelPart' 11 4 "foo="
+        (@?=) ih
+          [defInlayHint { _position = Position 13 21
+                        , _label = InR [ foo ]
+                        , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ]
+                        , _tooltip = Just $ InL "Expand positional record"
+                        , _paddingLeft = Nothing
+                        }]
     , mkInlayHintsTest "HsExpanded2" Nothing 23 $ \ih -> do
         let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded2"
         bar <- mkLabelPart' 14 4 "bar"

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+module Construction where
+
+data MyRec = MyRec
+  { foo :: Int
+  , bar :: Int
+  , baz :: Char
+  }
+
+convertMe :: () -> MyRec
+convertMe _ =
+  let foo = 3
+      bar = 5
+      baz = 'a'
+  in MyRec {..}

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

@@ -0,0 +1,19 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+module HsExpanded1DuplicateRecordFields where
+import Prelude
+
+ifThenElse :: Int -> Int -> Int ->  Int
+ifThenElse x y z = x + y + z
+
+data MyRec = MyRec
+  { foo :: Int }
+
+myRecExample = MyRec 5
+
+convertMe :: Int
+convertMe =
+  if (let MyRec {..} = myRecExample
+      in foo) then 1 else 2

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+module PositionalConstruction where
+
+data MyRec = MyRec
+  { foo :: Int
+  , bar :: Int
+  , baz :: Char
+  }
+
+convertMe :: () -> MyRec
+convertMe _ =
+  let a = 3
+      b = 5
+      c = 'a'
+  in MyRec a b c
+