From a91a2ee07755ba330862f6af42afafe8b50fb961 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sat, 17 May 2025 19:19:05 +0200 Subject: [PATCH 1/4] Strip prefixes added by DuplicateRecordFields to disambiguate record selectors from inlay hints --- .../src/Ide/Plugin/ExplicitFields.hs | 31 ++++++++--- .../test/Main.hs | 53 +++++++++++++++++++ .../ConstructionDuplicateRecordFields.hs | 17 ++++++ .../HsExpanded1DuplicateRecordFields.hs | 19 +++++++ ...tionalConstructionDuplicateRecordFields.hs | 17 ++++++ 5 files changed, 130 insertions(+), 7 deletions(-) create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/ConstructionDuplicateRecordFields.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1DuplicateRecordFields.hs create mode 100644 plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstructionDuplicateRecordFields.hs diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index be903ff924..495ea74784 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/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) @@ -48,6 +49,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) +import Development.IDE.GHC.CoreFile (occNamePrefixes) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (FieldLabel (flSelector), FieldOcc (FieldOcc), @@ -238,7 +240,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 @@ -287,7 +289,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 +412,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 +522,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 +563,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 +643,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 diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs index da84fd76cb..82ef449a25 100644 --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/ConstructionDuplicateRecordFields.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/ConstructionDuplicateRecordFields.hs new file mode 100644 index 0000000000..420711f0da --- /dev/null +++ b/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 {..} diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1DuplicateRecordFields.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/HsExpanded1DuplicateRecordFields.hs new file mode 100644 index 0000000000..1e37d14668 --- /dev/null +++ b/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 diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstructionDuplicateRecordFields.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstructionDuplicateRecordFields.hs new file mode 100644 index 0000000000..5227af9a83 --- /dev/null +++ b/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 + From 6605900eeed7bcb75d4ba14f64b2ade1bbeaf2b3 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sun, 18 May 2025 00:04:47 +0200 Subject: [PATCH 2/4] Fix style --- .../src/Ide/Plugin/ExplicitFields.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 495ea74784..b80dbe0f83 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -49,7 +49,6 @@ import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) -import Development.IDE.GHC.CoreFile (occNamePrefixes) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (FieldLabel (flSelector), FieldOcc (FieldOcc), @@ -83,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) From e657ed3e63e867ac01a37442957c842520360414 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 19 May 2025 09:43:43 +0200 Subject: [PATCH 3/4] Extract stripPrefixes to a common utility, convert comment to haddoc --- ghcide/src/Development/IDE/GHC/CoreFile.hs | 13 +++++++++++- .../IDE/Plugin/Completions/Logic.hs | 16 ++------------- .../src/Ide/Plugin/ExplicitFields.hs | 20 ++++--------------- 3 files changed, 18 insertions(+), 31 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/CoreFile.hs b/ghcide/src/Development/IDE/GHC/CoreFile.hs index 015c5e3aff..44cee45b62 100644 --- a/ghcide/src/Development/IDE/GHC/CoreFile.hs +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -10,7 +10,8 @@ module Development.IDE.GHC.CoreFile , readBinCoreFile , writeBinCoreFile , getImplicitBinds - , occNamePrefixes) where + , occNamePrefixes + , stripOccNamePrefix) where import Control.Monad import Control.Monad.IO.Class @@ -29,6 +30,7 @@ import GHC.Iface.Env #if MIN_VERSION_ghc(9,11,0) import qualified GHC.Iface.Load as Iface #endif +import Data.Monoid (First (..)) import GHC.Iface.Recomp.Binary (fingerprintBinMem) import GHC.IfaceToCore import GHC.Types.Id.Make @@ -264,3 +266,12 @@ occNamePrefixes = , "$c" , "$m" ] + +-- | 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 diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 9fdc196cd5..a40367760f 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -37,14 +37,13 @@ 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.CoreFile (stripOccNamePrefix) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -261,7 +260,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 +800,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 diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index b80dbe0f83..efbaa61df9 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -26,7 +26,6 @@ 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) @@ -82,7 +81,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.CoreFile (stripOccNamePrefix) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -240,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 = [ (stripPrefix $ 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 @@ -645,16 +644,5 @@ getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) 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 +printFieldName = stripOccNamePrefix . printOutputable + From deb890198ca54498be3933358a8396827883a8c4 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 19 May 2025 09:54:57 +0200 Subject: [PATCH 4/4] Move to GHC Util --- ghcide/src/Development/IDE/GHC/CoreFile.hs | 54 +----------------- ghcide/src/Development/IDE/GHC/Util.hs | 56 ++++++++++++++++++- .../IDE/Plugin/Completions/Logic.hs | 1 - .../src/Ide/Plugin/ExplicitFields.hs | 4 +- 4 files changed, 58 insertions(+), 57 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/CoreFile.hs b/ghcide/src/Development/IDE/GHC/CoreFile.hs index 44cee45b62..53d3840325 100644 --- a/ghcide/src/Development/IDE/GHC/CoreFile.hs +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -10,8 +10,7 @@ module Development.IDE.GHC.CoreFile , readBinCoreFile , writeBinCoreFile , getImplicitBinds - , occNamePrefixes - , stripOccNamePrefix) where + ) where import Control.Monad import Control.Monad.IO.Class @@ -30,7 +29,6 @@ import GHC.Iface.Env #if MIN_VERSION_ghc(9,11,0) import qualified GHC.Iface.Load as Iface #endif -import Data.Monoid (First (..)) import GHC.Iface.Recomp.Binary (fingerprintBinMem) import GHC.IfaceToCore import GHC.Types.Id.Make @@ -225,53 +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" - ] - --- | 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 diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index a6e0c10461..fb051bda5a 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/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" + ] + diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index a40367760f..7709d9b48f 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -43,7 +43,6 @@ 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 (stripOccNamePrefix) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index efbaa61df9..a761f648af 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -81,9 +81,9 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns mapConPatDetail, mapLoc, pattern RealSrcSpan, plusUFM_C, unitUFM) -import Development.IDE.GHC.CoreFile (stripOccNamePrefix) 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 (..),