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

Author: kozak

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

@@ -10,7 +10,7 @@ module Development.IDE.GHC.CoreFile
   , readBinCoreFile
   , writeBinCoreFile
   , getImplicitBinds
-  , occNamePrefixes) where
+  ) where
 
 import           Control.Monad
 import           Control.Monad.IO.Class
@@ -223,44 +223,3 @@ tc_iface_bindings (TopIfaceRec vs) = do
   vs' <- traverse (\(v, e) -> (v,) <$> tcIfaceExpr e) vs
   pure $ Rec vs'
 
--- | Prefixes that can occur in a GHC OccName
-occNamePrefixes :: [T.Text]
-occNamePrefixes =
-  [
-    -- long ones
-    "$con2tag_"
-  , "$tag2con_"
-  , "$maxtag_"
-
-  -- four chars
-  , "$sel:"
-  , "$tc'"
-
-  -- three chars
-  , "$dm"
-  , "$co"
-  , "$tc"
-  , "$cp"
-  , "$fx"
-
-  -- two chars
-  , "$W"
-  , "$w"
-  , "$m"
-  , "$b"
-  , "$c"
-  , "$d"
-  , "$i"
-  , "$s"
-  , "$f"
-  , "$r"
-  , "C:"
-  , "N:"
-  , "D:"
-  , "$p"
-  , "$L"
-  , "$f"
-  , "$t"
-  , "$c"
-  , "$m"
-  ]

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

@@ -27,7 +27,8 @@ module Development.IDE.GHC.Util(
     dontWriteHieFiles,
     disableWarningsAsErrors,
     printOutputable,
-    getExtensions
+    getExtensions,
+    stripOccNamePrefix,
     ) where
 
 import           Control.Concurrent
@@ -62,6 +63,7 @@ import           GHC.IO.Handle.Types
 import           Ide.PluginUtils                   (unescape)
 import           System.FilePath
 
+import           Data.Monoid                       (First (..))
 import           GHC.Data.EnumSet
 import           GHC.Data.FastString
 import           GHC.Data.StringBuffer
@@ -271,3 +273,55 @@ printOutputable =
 
 getExtensions :: ParsedModule -> [Extension]
 getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary
+
+-- | 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
+stripOccNamePrefix :: T.Text -> T.Text
+stripOccNamePrefix name = T.takeWhile (/=':') $ fromMaybe name $
+    getFirst $ foldMap (First . (`T.stripPrefix` name))
+    occNamePrefixes
+
+-- | Prefixes that can occur in a GHC OccName
+occNamePrefixes :: [T.Text]
+occNamePrefixes =
+  [
+    -- long ones
+    "$con2tag_"
+  , "$tag2con_"
+  , "$maxtag_"
+
+  -- four chars
+  , "$sel:"
+  , "$tc'"
+
+  -- three chars
+  , "$dm"
+  , "$co"
+  , "$tc"
+  , "$cp"
+  , "$fx"
+
+  -- two chars
+  , "$W"
+  , "$w"
+  , "$m"
+  , "$b"
+  , "$c"
+  , "$d"
+  , "$i"
+  , "$s"
+  , "$f"
+  , "$r"
+  , "C:"
+  , "N:"
+  , "D:"
+  , "$p"
+  , "$L"
+  , "$f"
+  , "$t"
+  , "$c"
+  , "$m"
+  ]
+

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

@@ -37,14 +37,12 @@ import           Data.Aeson                               (ToJSON (toJSON))
 import           Data.Function                            (on)
 
 import qualified Data.HashSet                             as HashSet
-import           Data.Monoid                              (First (..))
 import           Data.Ord                                 (Down (Down))
 import qualified Data.Set                                 as Set
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.GHC.Compat               hiding (isQual, ppr)
 import qualified Development.IDE.GHC.Compat               as GHC
 import           Development.IDE.GHC.Compat.Util
-import           Development.IDE.GHC.CoreFile             (occNamePrefixes)
 import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.Util
 import           Development.IDE.Plugin.Completions.Types
@@ -261,7 +259,7 @@ mkNameCompItem doc thingParent origName provenance isInfix !imp mod = CI {..}
     compKind = occNameToComKind origName
     isTypeCompl = isTcOcc origName
     typeText = Nothing
-    label = stripPrefix $ printOutputable origName
+    label = stripOccNamePrefix $ printOutputable origName
     insertText = case isInfix of
             Nothing         -> label
             Just LeftSide   -> label <> "`"
@@ -801,17 +799,6 @@ openingBacktick line prefixModule prefixText Position { _character=(fromIntegral
 
 -- ---------------------------------------------------------------------
 
--- | Under certain circumstance GHC generates some extra stuff that we
--- don't want in the autocompleted symbols
-    {- 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
-    -}
--- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
-stripPrefix :: T.Text -> T.Text
-stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $
-  getFirst $ foldMap (First . (`T.stripPrefix` name)) occNamePrefixes
-
 mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem
 mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r
   where

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

@@ -82,7 +82,8 @@ import           Development.IDE.GHC.Compat.Core      (Extension (NamedFieldPuns
                                                        pattern RealSrcSpan,
                                                        plusUFM_C, unitUFM)
 import           Development.IDE.GHC.Util             (getExtensions,
-                                                       printOutputable)
+                                                       printOutputable,
+                                                       stripOccNamePrefix)
 import           Development.IDE.Graph                (RuleResult)
 import           Development.IDE.Graph.Classes        (Hashable, NFData)
 import           Development.IDE.Spans.Pragmas        (NextPragmaInfo (..),
@@ -238,7 +239,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 = [ (stripOccNamePrefix $ 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
@@ -287,7 +288,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"
@@ -410,10 +411,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
@@ -520,7 +521,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)
 
@@ -561,7 +562,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)
@@ -641,3 +642,7 @@ 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 = stripOccNamePrefix . printOutputable
+

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

@@ -57,6 +57,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="
@@ -82,6 +100,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"
@@ -102,6 +145,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
+